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