Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCHSMU1

APCHSMU1.m

Go to the documentation of this file.
  1. APCHSMU1 ; IHS/CMI/LAB - utilities for hmr ;
  1. ;;2.0;IHS PCC SUITE;**2,11,16**;MAY 14, 2009;Build 9
  1. ;
  1. ;
  1. GETMEDS(P,APCHMBD,APCHMED,TAXM,TAXN,TAXC,APCHNAME,APCHZ) ;EP
  1. S TAXM=$G(TAXM)
  1. S TAXN=$G(TAXN)
  1. S TAXC=$G(TAXC)
  1. K ^TMP($J,"MEDS"),APCHZ
  1. S APCHNAME=$G(APCHNAME)
  1. NEW APCHC1,APCHINED,APCHINBD,APCHMIEN,APCHD,X,Y,T,T1,D,G,T2,C
  1. S APCHC1=0 K APCHZ
  1. S APCHINED=(9999999-APCHMED)-1,APCHINBD=(9999999-APCHMBD)
  1. F S APCHINED=$O(^AUPNVMED("AA",P,APCHINED)) Q:APCHINED=""!(APCHINED>APCHINBD) D
  1. .S APCHMIEN=0 F S APCHMIEN=$O(^AUPNVMED("AA",P,APCHINED,APCHMIEN)) Q:APCHMIEN'=+APCHMIEN D
  1. ..Q:'$D(^AUPNVMED(APCHMIEN,0))
  1. ..S APCHD=$P(^AUPNVMED(APCHMIEN,0),U)
  1. ..Q:APCHD=""
  1. ..Q:'$D(^PSDRUG(APCHD,0))
  1. ..S APCHC1=APCHC1+1
  1. ..S ^TMP($J,"MEDS","ORDER",(9999999-APCHINED),APCHC1)=(9999999-APCHINED)_U_$P(^PSDRUG(APCHD,0),U)_U_$P(^PSDRUG(APCHD,0),U)_U_APCHMIEN_U_$P(^AUPNVMED(APCHMIEN,0),U,3)
  1. ;reorder
  1. S APCHC1=0,X=0
  1. F S X=$O(^TMP($J,"MEDS","ORDER",X)) Q:X'=+X D
  1. .S Y=0 F S Y=$O(^TMP($J,"MEDS","ORDER",X,Y)) Q:Y'=+Y D
  1. ..S APCHC1=APCHC1+1
  1. ..S ^TMP($J,"MEDS",APCHC1)=^TMP($J,"MEDS","ORDER",X,Y)
  1. K ^TMP($J,"MEDS","ORDER")
  1. S T="" I TAXM]"" S T=$O(^ATXAX("B",TAXM,0))
  1. S T1="" I TAXN]"" S T1=$O(^ATXAX("B",TAXN,0))
  1. S T2="" I TAXC]"" S T2=$O(^ATXAX("B",TAXC,0))
  1. S APCHC1=0,X=0 F S X=$O(^TMP($J,"MEDS",X)) Q:X'=+X S Y=+$P(^TMP($J,"MEDS",X),U,4) D
  1. .Q:'$D(^AUPNVMED(Y,0))
  1. .S G=0
  1. .S D=$P(^AUPNVMED(Y,0),U)
  1. .S C=$P($G(^PSDRUG(D,0)),U,2)
  1. .I C]"",T2,$D(^ATXAX(T2,21,"B",C)) S G=1
  1. .S C=$P($G(^PSDRUG(D,2)),U,4)
  1. .I C]"",T1,$D(^ATXAX(T1,21,"B",C)) S G=1
  1. .I T,$D(^ATXAX(T,21,"B",D)) S G=1
  1. .I APCHNAME]"",$P(^PSDRUG(D,0),U)[APCHNAME S G=1
  1. .I TAXM="",TAXN="",TAXC="",APCHNAME="" S G=1 ;WANTS ALL MEDS
  1. .I G=1 S APCHC1=APCHC1+1,APCHZ(APCHC1)=^TMP($J,"MEDS",X)
  1. .Q
  1. K ^TMP($J,"MEDS")
  1. K APCHINED,APCHINBD,APCHMBD,APCHMED,APCHD,APCHC1,APCHNAME
  1. Q
  1. CPTI(P,BDATE,EDATE,CPTI,SCEX,SCLN,SMOD) ;EP - did patient have this cpt (ien) in date range
  1. I '$G(P) Q ""
  1. I $G(CPTI)="" Q ""
  1. I $G(BDATE)="" Q ""
  1. I $G(EDATE)="" Q ""
  1. S SCEX=$G(SCEX)
  1. S SCLN=$G(SCLN)
  1. S SMOD=$G(SMOD)
  1. I '$D(^ICPT(CPTI)) Q "" ;not a valid cpt ien
  1. I '$D(^AUPNVCPT("AA",P)) Q "" ;no cpts for this patient
  1. NEW D,BD,ED,X,Y,D,G,V,I,M,M1,Z,J,K,Q
  1. S ED=9999999-EDATE-1,BD=9999999-BDATE,G=""
  1. F S ED=$O(^AUPNVCPT("AA",P,CPTI,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
  1. .S I=0 F S I=$O(^AUPNVCPT("AA",P,CPTI,ED,I)) Q:I'=+I!(G) D
  1. ..S V=$P($G(^AUPNVCPT(I,0)),U,3)
  1. ..I SCEX]"",SCEX[$P(^AUPNVSIT(V,0),U,7) Q
  1. ..I SCLN]"",$$CLINIC^APCLV(V,"C")=SCLN Q
  1. ..S M=$$VAL^XBDIQ1(9000010.18,I,.08)
  1. ..S M1=$$VAL^XBDIQ1(9000010.18,I,.09)
  1. ..S Q=0
  1. ..I SMOD]"" F J=1:1 S K=$P(SMOD,";",J) Q:K="" I K=M S Q=1
  1. ..Q:Q
  1. ..I SMOD]"" F J=1:1 S K=$P(SMOD,";",J) Q:K="" I K=M1 S Q=1
  1. ..Q:Q
  1. ..S G="1"_"^"_(9999999-ED)
  1. Q G
  1. ;
  1. TRANI(P,BDATE,EDATE,CPTI) ;EP
  1. I '$G(P) Q ""
  1. I $G(TRANI)="" Q ""
  1. I $G(BDATE)="" Q ""
  1. I $G(EDATE)="" Q ""
  1. I '$D(^ICPT(CPTI)) Q ""
  1. I '$D(^AUPNVTC("AC",P)) Q "" ;no cpts for this patient
  1. NEW X,V,C,G
  1. S G=""
  1. S X=0 F S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X D
  1. .S C=$P($G(^AUPNVTC(X,0)),U,7)
  1. .Q:C'=CPTI
  1. .S V=$P(^AUPNVTC(X,0),U,3)
  1. .S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1. .Q:V<BDATE
  1. .Q:V>EDATE
  1. .S G="1"_"^"_V
  1. Q G
  1. ;
  1. CPTREFT(P,BDATE,EDATE,T) ;EP - return ien of CPT entry if patient had this CPT
  1. I '$G(P) Q ""
  1. I '$G(T) Q ""
  1. I $G(EDATE)="" Q ""
  1. I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
  1. NEW G,X,Y,Z,I
  1. S G=""
  1. S I=0 F S I=$O(^AUPNPREF("AA",P,81,I)) Q:I=""!($P(G,U)) D
  1. .S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X!($P(G,U)) S Y=0 F S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<BDATE&(D'>EDATE) D
  1. ..Q:'$$ICD^ATXAPI(I,T,1)
  1. ..S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
  1. .Q
  1. Q G
  1. REFTAX(P,F,T,B,E) ;EP - refused an item in a taxonomy
  1. I '$G(P) Q ""
  1. I '$G(F) Q ""
  1. I '$G(T) Q ""
  1. I $G(B)="" Q ""
  1. I $G(E)="" Q ""
  1. NEW G,X,Y,%DT,T1 S X=B,%DT="P" D ^%DT S B=Y
  1. S X=E,%DT="P" D ^%DT S E=Y
  1. S T1=0,G="" F S T1=$O(^ATXAX(T,21,"B",T1)) Q:T1=""!(G) D
  1. .S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,F,T1,X)) Q:X'=+X!(G) S Y=0 F S Y=$O(^AUPNPREF("AA",P,F,T1,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
  1. Q G
  1. IPLSNO(P,T,B) ;EP - any problem list entry with a SNOMED in T
  1. NEW OUT,IN,C,G,Y,X,I,SNL,SNI
  1. S OUT="SNL"
  1. S B=$G(B)
  1. S X=$$SUBLST^BSTSAPI(OUT,T)
  1. ;BUILD INDEX
  1. S C=0 F S C=$O(SNL(C)) Q:C'=+C S I=$P(SNL(C),U,1) I I]"" S SNI(I)=SNL(C)
  1. K SNL
  1. ;LOOP PROBLEM LIST
  1. S (X,G)=""
  1. F S X=$O(^AUPNPROB("APCT",P,X)) Q:X=""!(G) D
  1. .S Y=0 F S Y=$O(^AUPNPROB("APCT",P,X,Y)) Q:Y'=+Y!(G) D
  1. ..Q:'$D(^AUPNPROB(Y,0))
  1. ..Q:$P(^AUPNPROB(Y,0),U,12)="D" ;deleted
  1. ..I 'B Q:$P(^AUPNPROB(Y,0),U,12)="I" ;inactive - per susan 5.3.16
  1. ..I $D(SNI(X)) S G=1_U_$$CONCPT^AUPNVUTL(X)_" on their Problem List"
  1. Q G
  1. PAPCPTS ;;
  1. ;;88141
  1. ;;88142
  1. ;;88143
  1. ;;88144
  1. ;;88145
  1. ;;88146
  1. ;;88147
  1. ;;88148
  1. ;;88150
  1. ;;88152
  1. ;;88153
  1. ;;88154
  1. ;;88155
  1. ;;88156
  1. ;;88157
  1. ;;88158
  1. ;;88164
  1. ;;88165
  1. ;;88166
  1. ;;88167
  1. ;;
  1. FLUCPTS ;;
  1. ;;90657
  1. ;;90656
  1. ;;90658
  1. ;;90655
  1. ;;90724
  1. ;;90711
  1. ;;90659
  1. ;;90660
  1. ;;
  1. SIGCPTS ;;
  1. ;;45330
  1. ;;45331
  1. ;;45332
  1. ;;45333
  1. ;;45334
  1. ;;45336
  1. ;;45337
  1. ;;45338
  1. ;;45339
  1. ;;45341
  1. ;;45342
  1. ;;45345
  1. ;;
  1. BECPTS ;;
  1. ;;74270
  1. ;;74275
  1. ;;74280
  1. ;;
  1. COLOCPTS ;;
  1. ;;45355
  1. ;;45360
  1. ;;45361
  1. ;;45362
  1. ;;45363
  1. ;;45364
  1. ;;45365
  1. ;;45366
  1. ;;45367
  1. ;;45368
  1. ;;45369
  1. ;;45370
  1. ;;45371
  1. ;;45372
  1. ;;45378
  1. ;;45379
  1. ;;45380
  1. ;;45382
  1. ;;45383
  1. ;;45384
  1. ;;45385
  1. ;;45387
  1. ;;