BDMD4DU ; IHS/CMI/LAB - gpra utility calls ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**5**;JUN 14, 2007
;
;
WH(P,BDATE,EDATE,T,F) ;EP
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
;go through procedures in a date range for this patient, check proc type
NEW D,X,Y,G,V,O
S (G,V)=0,I="" F S V=$O(^BWPCD("C",P,V)) Q:V="" D
.Q:'$D(^BWPCD(V,0))
.I $P(^BWPCD(V,0),U,4)'=T Q
.Q:$$UP^XLFSTR($$VAL^XBDIQ1(9002086.1,V,.05))="ERROR/DISREGARD"
.S D=$P(^BWPCD(V,0),U,12)
.Q:D<BDATE
.Q:D>EDATE
.S I=$O(G(0)) I I>D Q
.S G=V,G(D)=""
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S D=$P(^BWPCD(G,0),U,12) Q D
I F=4 S D=$P(^BWPCD(G,0),U,12) Q $$FMTE^XLFDT(D)
Q ""
PLCODE(P,A) ;EP
I $G(P)="" Q ""
I $G(A)="" Q ""
N T
;S T=$O(^ICD9("AB",A,0))
S T=+$$CODEN^ICDCODE(A,80)
I T'>0 Q ""
N X,Y,I S (X,Y,I)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) I $D(^AUPNPROB(X,0)),$P(^AUPNPROB(X,0),U,12)'="D" S Y=$P(^AUPNPROB(X,0),U) I Y=T S I=1
Q I
PLTAX(P,A) ;EP - is DX on problem list 1 or 0
I $G(P)="" Q ""
I $G(A)="" Q ""
N T S T=$O(^ATXAX("B",A,0))
I 'T Q ""
N X,Y,I S (X,Y,I)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) I $D(^AUPNPROB(X,0)),$P(^AUPNPROB(X,0),U,12)'="D" S Y=$P(^AUPNPROB(X,0),U) I $$ICD^ATXCHK(Y,T,9) S I=1
Q I
CPT(P,BDATE,EDATE,T,F,SCEX) ;EP - return ien of CPT entry if patient had this CPT
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
S SCEX=$G(SCEX)
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
;go through visits in a date range for this patient, check cpts
NEW D,BD,ED,X,Y,D,G,V
S ED=(9999999-EDATE),BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVCPT("AD",V))
..I SCEX]"",SCEX[$P(^AUPNVSIT(V,0),U,7) Q
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(G) D
...I $$ICD^ATXCHK($P(^AUPNVCPT(X,0),U),T,1) S G=X
...Q
..Q
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
I F=4 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
I F=5 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVCPT(G,0),U)),U,2)
I F=6 S V=$P(^AUPNVCPT(G,0),U,3) I V Q 1_"^"_$P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVCPT(G,0),U)),U,2)_"^"_G
Q ""
RAD(P,BDATE,EDATE,T,F) ;EP - return ien of CPT entry if patient had this CPT
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
;go through visits in a date range for this patient, check cpts
NEW D,BD,ED,X,Y,D,G,V,C
S ED=(9999999-EDATE),BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVRAD("AD",V))
..S X=0 F S X=$O(^AUPNVRAD("AD",V,X)) Q:X'=+X!(G) D
...S C=$P(^AUPNVRAD(X,0),U) Q:C="" S C=$P($G(^RAMIS(71,C,0)),U,9) Q:C=""
...I $$ICD^ATXCHK(C,T,1) S G=X
...Q
..Q
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
I F=4 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
I F=5 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P(^RAMIS(71,$P(^AUPNVRAD(G,0),U),0),U,9)
I F=6 S V=$P(^AUPNVRAD(G,0),U,3) I V Q 1_"^"_$P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P(^RAMIS(71,$P(^AUPNVRAD(G,0),U),0),U)_"^"_G
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)_"^"_$$VAL^XBDIQ1(9000010.18,I,.01)
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_"^"_$$VAL^XBDIQ1(9000010.33,I,.07)
Q G
TRAN(P,BDATE,EDATE,T,F) ;EP - return ien of CPT entry if patient had this CPT IN A TRAN CODE
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
;go through visits in a date range for this patient, check cpts
NEW D,BD,ED,X,Y,D,G,V
S ED=(9999999-EDATE),BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVTC("AD",V))
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X!(G) D
...I $$ICD^ATXCHK($P(^AUPNVTC(X,0),U,7),T,1) S G=X
...Q
..Q
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S V=$P(^AUPNVTC(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
I F=4 S V=$P(^AUPNVTC(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
I F=5 S V=$P(^AUPNVTC(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVTC(G,0),U,7)),U,2)
I F=6 S V=$P(^AUPNVTC(G,0),U,3) I V Q 1_"^"_$P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVTC(G,0),U,7)),U,2)_"^"_G
Q ""
;
LASTITEM(P,BD,ED,BDMT,BDMV) ;PEP - return last item APCLV OF TYPE APCLT DURING BD TO ED IN FORM APCLF
I $G(BD)="" S BD=$$DOB^AUPNPAT(P)
I $G(ED)="" S ED=DT
I $G(BDMT)="" Q ""
I $G(BDMV)="" Q ""
NEW BDMR,%,E,Y K R S %=P_"^LAST "_BDMT_" "_BDMV_";DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BDMR(")
I '$D(BDMR(1)) Q ""
Q 1_U_$P(BDMR(1),U,1)_U_$P(BDMR(1),U,3)_U_$P(BDMR(1),U,2)
GETMEDS(P,BDMMBD,BDMMED,TAXM,TAXN,TAXC,BDMDNAME,BDMZ) ;EP
S TAXM=$G(TAXM)
S TAXN=$G(TAXN)
S TAXC=$G(TAXC)
K ^TMP($J,"MEDS"),BDMZ
S BDMDNAME=$G(BDMDNAME)
NEW BDMC1,BDMINED,BDMINBD,BDMMIEN,BDMD,X,Y,T,T1,D,G
S BDMC1=0 K BDMZ
S BDMINED=(9999999-BDMMED)-1,BDMINBD=(9999999-BDMMBD)
F S BDMINED=$O(^AUPNVMED("AA",P,BDMINED)) Q:BDMINED=""!(BDMINED>BDMINBD) D
.S BDMMIEN=0 F S BDMMIEN=$O(^AUPNVMED("AA",P,BDMINED,BDMMIEN)) Q:BDMMIEN'=+BDMMIEN D
..Q:'$D(^AUPNVMED(BDMMIEN,0))
..S BDMD=$P(^AUPNVMED(BDMMIEN,0),U)
..Q:BDMD=""
..Q:'$D(^PSDRUG(BDMD,0))
..S BDMC1=BDMC1+1
..S ^TMP($J,"MEDS","ORDER",(9999999-BDMINED),BDMC1)=(9999999-BDMINED)_U_$P(^PSDRUG(BDMD,0),U)_U_$P(^PSDRUG(BDMD,0),U)_U_BDMMIEN_U_$P(^AUPNVMED(BDMMIEN,0),U,3)
;reorder
S BDMC1=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 BDMC1=BDMC1+1
..S ^TMP($J,"MEDS",BDMC1)=^TMP($J,"MEDS","ORDER",X,Y)
K ^TMP($J,"MEDS","ORDER")
S T="" I TAXM]"" S T=$O(^ATXAX("B",TAXM,0)) I T="" W BDMBOMB
S T1="" I TAXN]"" S T1=$O(^ATXAX("B",TAXN,0)) I T1="" W BDMBOMB
S T2="" I TAXC]"" S T2=$O(^ATXAX("B",TAXC,0))
S BDMC1=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 BDMDNAME]"",$P(^PSDRUG(D,0),U)[BDMDNAME S G=1
.I TAXM="",TAXN="",TAXC="" S G=1 ;WANTS ALL MEDS
.I G=1 S BDMC1=BDMC1+1,BDMZ(BDMC1)=^TMP($J,"MEDS",X)
.Q
K ^TMP($J,"MEDS")
K BDMINED,BDMINBD,BDMMBD,BDMMED,BDMD,BDMC1,BDMDNAME
Q
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^ATXCHK(I,T,1)
..S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)_"^"_$P(^ICPT(I,0),U)
.Q
Q G
BDMD4DU ; IHS/CMI/LAB - gpra utility calls ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**5**;JUN 14, 2007
+2 ;
+3 ;
WH(P,BDATE,EDATE,T,F) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 IF $GET(EDATE)=""
QUIT ""
+5 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+6 ;go through procedures in a date range for this patient, check proc type
+7 NEW D,X,Y,G,V,O
+8 SET (G,V)=0
SET I=""
FOR
SET V=$ORDER(^BWPCD("C",P,V))
IF V=""
QUIT
Begin DoDot:1
+9 IF '$DATA(^BWPCD(V,0))
QUIT
+10 IF $PIECE(^BWPCD(V,0),U,4)'=T
QUIT
+11 IF $$UP^XLFSTR($$VAL^XBDIQ1(9002086.1,V,.05))="ERROR/DISREGARD"
QUIT
+12 SET D=$PIECE(^BWPCD(V,0),U,12)
+13 IF D<BDATE
QUIT
+14 IF D>EDATE
QUIT
+15 SET I=$ORDER(G(0))
IF I>D
QUIT
+16 SET G=V
SET G(D)=""
+17 QUIT
End DoDot:1
+18 IF 'G
QUIT ""
+19 IF F=1
QUIT $SELECT(G:1,1:"")
+20 IF F=2
QUIT G
+21 IF F=3
SET D=$PIECE(^BWPCD(G,0),U,12)
QUIT D
+22 IF F=4
SET D=$PIECE(^BWPCD(G,0),U,12)
QUIT $$FMTE^XLFDT(D)
+23 QUIT ""
PLCODE(P,A) ;EP
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(A)=""
QUIT ""
+3 NEW T
+4 ;S T=$O(^ICD9("AB",A,0))
+5 SET T=+$$CODEN^ICDCODE(A,80)
+6 IF T'>0
QUIT ""
+7 NEW X,Y,I
SET (X,Y,I)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
IF $DATA(^AUPNPROB(X,0))
IF $PIECE(^AUPNPROB(X,0),U,12)'="D"
SET Y=$PIECE(^AUPNPROB(X,0),U)
IF Y=T
SET I=1
+8 QUIT I
PLTAX(P,A) ;EP - is DX on problem list 1 or 0
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(A)=""
QUIT ""
+3 NEW T
SET T=$ORDER(^ATXAX("B",A,0))
+4 IF 'T
QUIT ""
+5 NEW X,Y,I
SET (X,Y,I)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
IF $DATA(^AUPNPROB(X,0))
IF $PIECE(^AUPNPROB(X,0),U,12)'="D"
SET Y=$PIECE(^AUPNPROB(X,0),U)
IF $$ICD^ATXCHK(Y,T,9)
SET I=1
+6 QUIT I
CPT(P,BDATE,EDATE,T,F,SCEX) ;EP - return ien of CPT entry if patient had this CPT
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 SET SCEX=$GET(SCEX)
+5 IF $GET(EDATE)=""
QUIT ""
+6 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+7 ;go through visits in a date range for this patient, check cpts
+8 NEW D,BD,ED,X,Y,D,G,V
+9 SET ED=(9999999-EDATE)
SET BD=9999999-BDATE
SET G=0
+10 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+11 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+12 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+13 IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+14 IF SCEX]""
IF SCEX[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+16 IF $$ICD^ATXCHK($PIECE(^AUPNVCPT(X,0),U),T,1)
SET G=X
+17 QUIT
End DoDot:3
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 IF 'G
QUIT ""
+21 IF F=1
QUIT $SELECT(G:1,1:"")
+22 IF F=2
QUIT G
+23 IF F=3
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+24 IF F=4
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $$FMTE^XLFDT($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+25 IF F=5
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVCPT(G,0),U)),U,2)
+26 IF F=6
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT 1_"^"_$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVCPT(G,0),U)),U,2)_"^"_G
+27 QUIT ""
RAD(P,BDATE,EDATE,T,F) ;EP - return ien of CPT entry if patient had this CPT
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 IF $GET(EDATE)=""
QUIT ""
+5 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+6 ;go through visits in a date range for this patient, check cpts
+7 NEW D,BD,ED,X,Y,D,G,V,C
+8 SET ED=(9999999-EDATE)
SET BD=9999999-BDATE
SET G=0
+9 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 IF '$DATA(^AUPNVRAD("AD",V))
QUIT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVRAD("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+14 SET C=$PIECE(^AUPNVRAD(X,0),U)
IF C=""
QUIT
SET C=$PIECE($GET(^RAMIS(71,C,0)),U,9)
IF C=""
QUIT
+15 IF $$ICD^ATXCHK(C,T,1)
SET G=X
+16 QUIT
End DoDot:3
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 IF 'G
QUIT ""
+20 IF F=1
QUIT $SELECT(G:1,1:"")
+21 IF F=2
QUIT G
+22 IF F=3
SET V=$PIECE(^AUPNVRAD(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+23 IF F=4
SET V=$PIECE(^AUPNVRAD(G,0),U,3)
IF V
QUIT $$FMTE^XLFDT($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+24 IF F=5
SET V=$PIECE(^AUPNVRAD(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE(^RAMIS(71,$PIECE(^AUPNVRAD(G,0),U),0),U,9)
+25 IF F=6
SET V=$PIECE(^AUPNVRAD(G,0),U,3)
IF V
QUIT 1_"^"_$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE(^RAMIS(71,$PIECE(^AUPNVRAD(G,0),U),0),U)_"^"_G
+26 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)_"^"_$$VAL^XBDIQ1(9000010.18,I,.01)
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_"^"_$$VAL^XBDIQ1(9000010.33,I,.07)
End DoDot:1
+17 QUIT G
TRAN(P,BDATE,EDATE,T,F) ;EP - return ien of CPT entry if patient had this CPT IN A TRAN CODE
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 IF $GET(EDATE)=""
QUIT ""
+5 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+6 ;go through visits in a date range for this patient, check cpts
+7 NEW D,BD,ED,X,Y,D,G,V
+8 SET ED=(9999999-EDATE)
SET BD=9999999-BDATE
SET G=0
+9 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 IF '$DATA(^AUPNVTC("AD",V))
QUIT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+14 IF $$ICD^ATXCHK($PIECE(^AUPNVTC(X,0),U,7),T,1)
SET G=X
+15 QUIT
End DoDot:3
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 IF 'G
QUIT ""
+19 IF F=1
QUIT $SELECT(G:1,1:"")
+20 IF F=2
QUIT G
+21 IF F=3
SET V=$PIECE(^AUPNVTC(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+22 IF F=4
SET V=$PIECE(^AUPNVTC(G,0),U,3)
IF V
QUIT $$FMTE^XLFDT($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+23 IF F=5
SET V=$PIECE(^AUPNVTC(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVTC(G,0),U,7)),U,2)
+24 IF F=6
SET V=$PIECE(^AUPNVTC(G,0),U,3)
IF V
QUIT 1_"^"_$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVTC(G,0),U,7)),U,2)_"^"_G
+25 QUIT ""
+26 ;
LASTITEM(P,BD,ED,BDMT,BDMV) ;PEP - return last item APCLV OF TYPE APCLT DURING BD TO ED IN FORM APCLF
+1 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+2 IF $GET(ED)=""
SET ED=DT
+3 IF $GET(BDMT)=""
QUIT ""
+4 IF $GET(BDMV)=""
QUIT ""
+5 NEW BDMR,%,E,Y
KILL R
SET %=P_"^LAST "_BDMT_" "_BDMV_";DURING "_BD_"-"_ED
SET E=$$START1^APCLDF(%,"BDMR(")
+6 IF '$DATA(BDMR(1))
QUIT ""
+7 QUIT 1_U_$PIECE(BDMR(1),U,1)_U_$PIECE(BDMR(1),U,3)_U_$PIECE(BDMR(1),U,2)
GETMEDS(P,BDMMBD,BDMMED,TAXM,TAXN,TAXC,BDMDNAME,BDMZ) ;EP
+1 SET TAXM=$GET(TAXM)
+2 SET TAXN=$GET(TAXN)
+3 SET TAXC=$GET(TAXC)
+4 KILL ^TMP($JOB,"MEDS"),BDMZ
+5 SET BDMDNAME=$GET(BDMDNAME)
+6 NEW BDMC1,BDMINED,BDMINBD,BDMMIEN,BDMD,X,Y,T,T1,D,G
+7 SET BDMC1=0
KILL BDMZ
+8 SET BDMINED=(9999999-BDMMED)-1
SET BDMINBD=(9999999-BDMMBD)
+9 FOR
SET BDMINED=$ORDER(^AUPNVMED("AA",P,BDMINED))
IF BDMINED=""!(BDMINED>BDMINBD)
QUIT
Begin DoDot:1
+10 SET BDMMIEN=0
FOR
SET BDMMIEN=$ORDER(^AUPNVMED("AA",P,BDMINED,BDMMIEN))
IF BDMMIEN'=+BDMMIEN
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVMED(BDMMIEN,0))
QUIT
+12 SET BDMD=$PIECE(^AUPNVMED(BDMMIEN,0),U)
+13 IF BDMD=""
QUIT
+14 IF '$DATA(^PSDRUG(BDMD,0))
QUIT
+15 SET BDMC1=BDMC1+1
+16 SET ^TMP($JOB,"MEDS","ORDER",(9999999-BDMINED),BDMC1)=(9999999-BDMINED)_U_$PIECE(^PSDRUG(BDMD,0),U)_U_$PIECE(^PSDRUG(BDMD,0),U)_U_BDMMIEN_U_$PIECE(^AUPNVMED(BDMMIEN,0),U,3)
End DoDot:2
End DoDot:1
+17 ;reorder
+18 SET BDMC1=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 BDMC1=BDMC1+1
+22 SET ^TMP($JOB,"MEDS",BDMC1)=^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))
IF T=""
WRITE BDMBOMB
+25 SET T1=""
IF TAXN]""
SET T1=$ORDER(^ATXAX("B",TAXN,0))
IF T1=""
WRITE BDMBOMB
+26 SET T2=""
IF TAXC]""
SET T2=$ORDER(^ATXAX("B",TAXC,0))
+27 SET BDMC1=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 BDMDNAME]""
IF $PIECE(^PSDRUG(D,0),U)[BDMDNAME
SET G=1
+37 ;WANTS ALL MEDS
IF TAXM=""
IF TAXN=""
IF TAXC=""
SET G=1
+38 IF G=1
SET BDMC1=BDMC1+1
SET BDMZ(BDMC1)=^TMP($JOB,"MEDS",X)
+39 QUIT
End DoDot:1
+40 KILL ^TMP($JOB,"MEDS")
+41 KILL BDMINED,BDMINBD,BDMMBD,BDMMED,BDMD,BDMC1,BDMDNAME
+42 QUIT
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^ATXCHK(I,T,1)
QUIT
+10 SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)_"^"_$PIECE(^ICPT(I,0),U)
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT G
