BGP8CU ;IHS/CMI/LAB - calc cms measures;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
;
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:80)-$L(X)\2)_X
;----------
EOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR(0)="E" D ^DIR
Q
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
;
GETMEDS(P,BGPMBD,BGPMED,TAX1,TAX2,TAX3,EXP,ADM,BGPDNAME,BGPC,LAST) ;EP
K ^TMP($J,"MEDS")
S LAST=$G(LAST)
NEW BGPC1,T,T1,T2,X,Y,G,D,C,BGPZ
S BGPDNAME=$G(BGPDNAME)
S BGPC1=0 K BGPZ
S Y="^TMP($J,""MEDS"",",X=P_"^ALL MED;DURING "_$$FMTE^XLFDT(BGPMBD)_"-"_$$FMTE^XLFDT(BGPMED) S E=$$START1^APCLDF(X,Y)
S T="" I TAX1]"" S T=$O(^ATXAX("B",TAX1,0))
S T1="" I TAX2]"" S T1=$O(^ATXAX("B",TAX2,0))
S T2="" I TAX3]"" S T2=$O(^ATXAX("B",TAX3,0))
S 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 BGPDNAME]"",$P(^PSDRUG(D,0),U)[BGPDNAME S G=1
.Q:'G
.I $G(EXP) Q:$$EXP(Y,ADM)
.I G=1 D
..S N=$P(^TMP($J,"MEDS",X),U,2)_" "_$P(^AUPNVMED(Y,0),U,5)_" qty: "_$P(^AUPNVMED(Y,0),U,6)_" days: "_$P(^AUPNVMED(Y,0),U,7)_" "_$$DATE^BGP8UTL($P(^TMP($J,"MEDS",X),U))
..I $P(^AUPNVMED(Y,0),U,8)]"" S N=N_" D/C "_$$DATE^BGP8UTL($P(^AUPNVMED(Y,0),U,8))
..S BGPZ($P(^TMP($J,"MEDS",X),U,2),(9999999-$P(^TMP($J,"MEDS",X),U)))=N
.Q
I 'LAST D
.S N="" F S N=$O(BGPZ(N)) Q:N="" D
..S D=0,D=$O(BGPZ(N,D)) I '$D(BGPY("B",N,D)) S BGPC=BGPC+1,BGPY(BGPC)=BGPZ(N,D),BGPY("B",N,D)=""
I LAST D
.S N="" F S N=$O(BGPZ(N)) Q:N="" D
..S D=0,D=$O(BGPZ(N,D)) S BGPY(D)=BGPZ(N,D)
..S X=$O(BGPY(0)) S X=BGPY(X)
..K BGPY
..S BGPY=X
Q
EXP(Y,ADM) ;
NEW G,V,N,Z,E
S G=0 ;not expired
S N=$P($G(^AUPNVMED(Y,0)),U,7) ;DAYS SUPPLY
S V=$P(^AUPNVMED(Y,0),U,3)
S Z=$S($D(^PSRX("APCC",Y)):$O(^(Y,0)),1:0) I Z D
.S E=$P($G(^PSRX(Z,2)),U,6)
.I E<ADM S G=1 ;prescription expired prior to admission date
I $$FMADD^XLFDT($P($P(^AUPNVSIT(V,0),U),"."),N)<ADM S G=1
Q G
BGP8CU ;IHS/CMI/LAB - calc cms measures;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
+3 ;
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:80)-$LENGTH(X)\2)_X
+2 ;----------
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
QUIT
+3 NEW DIR
+4 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+5 SET DIR(0)="E"
DO ^DIR
+6 QUIT
+7 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
+3 ;
GETMEDS(P,BGPMBD,BGPMED,TAX1,TAX2,TAX3,EXP,ADM,BGPDNAME,BGPC,LAST) ;EP
+1 KILL ^TMP($JOB,"MEDS")
+2 SET LAST=$GET(LAST)
+3 NEW BGPC1,T,T1,T2,X,Y,G,D,C,BGPZ
+4 SET BGPDNAME=$GET(BGPDNAME)
+5 SET BGPC1=0
KILL BGPZ
+6 SET Y="^TMP($J,""MEDS"","
SET X=P_"^ALL MED;DURING "_$$FMTE^XLFDT(BGPMBD)_"-"_$$FMTE^XLFDT(BGPMED)
SET E=$$START1^APCLDF(X,Y)
+7 SET T=""
IF TAX1]""
SET T=$ORDER(^ATXAX("B",TAX1,0))
+8 SET T1=""
IF TAX2]""
SET T1=$ORDER(^ATXAX("B",TAX2,0))
+9 SET T2=""
IF TAX3]""
SET T2=$ORDER(^ATXAX("B",TAX3,0))
+10 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
+11 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+12 SET G=0
+13 SET D=$PIECE(^AUPNVMED(Y,0),U)
+14 SET C=$PIECE($GET(^PSDRUG(D,0)),U,2)
+15 IF C]""
IF T2
IF $DATA(^ATXAX(T2,21,"B",C))
SET G=1
+16 SET C=$PIECE($GET(^PSDRUG(D,2)),U,4)
+17 IF C]""
IF T1
IF $DATA(^ATXAX(T1,21,"B",C))
SET G=1
+18 IF T
IF $DATA(^ATXAX(T,21,"B",D))
SET G=1
+19 IF BGPDNAME]""
IF $PIECE(^PSDRUG(D,0),U)[BGPDNAME
SET G=1
+20 IF 'G
QUIT
+21 IF $GET(EXP)
IF $$EXP(Y,ADM)
QUIT
+22 IF G=1
Begin DoDot:2
+23 SET N=$PIECE(^TMP($JOB,"MEDS",X),U,2)_" "_$PIECE(^AUPNVMED(Y,0),U,5)_" qty: "_$PIECE(^AUPNVMED(Y,0),U,6)_" days: "_$PIECE(^AUPNVMED(Y,0),U,7)_" "_$$DATE^BGP8UTL($PIECE(^TMP($JOB,"MEDS",X),U))
+24 IF $PIECE(^AUPNVMED(Y,0),U,8)]""
SET N=N_" D/C "_$$DATE^BGP8UTL($PIECE(^AUPNVMED(Y,0),U,8))
+25 SET BGPZ($PIECE(^TMP($JOB,"MEDS",X),U,2),(9999999-$PIECE(^TMP($JOB,"MEDS",X),U)))=N
End DoDot:2
+26 QUIT
End DoDot:1
+27 IF 'LAST
Begin DoDot:1
+28 SET N=""
FOR
SET N=$ORDER(BGPZ(N))
IF N=""
QUIT
Begin DoDot:2
+29 SET D=0
SET D=$ORDER(BGPZ(N,D))
IF '$DATA(BGPY("B",N,D))
SET BGPC=BGPC+1
SET BGPY(BGPC)=BGPZ(N,D)
SET BGPY("B",N,D)=""
End DoDot:2
End DoDot:1
+30 IF LAST
Begin DoDot:1
+31 SET N=""
FOR
SET N=$ORDER(BGPZ(N))
IF N=""
QUIT
Begin DoDot:2
+32 SET D=0
SET D=$ORDER(BGPZ(N,D))
SET BGPY(D)=BGPZ(N,D)
+33 SET X=$ORDER(BGPY(0))
SET X=BGPY(X)
+34 KILL BGPY
+35 SET BGPY=X
End DoDot:2
End DoDot:1
+36 QUIT
EXP(Y,ADM) ;
+1 NEW G,V,N,Z,E
+2 ;not expired
SET G=0
+3 ;DAYS SUPPLY
SET N=$PIECE($GET(^AUPNVMED(Y,0)),U,7)
+4 SET V=$PIECE(^AUPNVMED(Y,0),U,3)
+5 SET Z=$SELECT($DATA(^PSRX("APCC",Y)):$ORDER(^(Y,0)),1:0)
IF Z
Begin DoDot:1
+6 SET E=$PIECE($GET(^PSRX(Z,2)),U,6)
+7 ;prescription expired prior to admission date
IF E<ADM
SET G=1
End DoDot:1
+8 IF $$FMADD^XLFDT($PIECE($PIECE(^AUPNVSIT(V,0),U),"."),N)<ADM
SET G=1
+9 QUIT G
