APCMVAEM ; IHS/CMI/LAB - V2 MED BY PROV SUB RTN KFOX ;
;;1.0;IHS MU PERFORMANCE REPORTS;**5,6**;MAR 26, 2012;Build 65
START ;Set beginning/ending sort dates for ORDERS
S %DT="AE",%DT("A")="Enter Start Date range: " D ^%DT
I (Y'>0)!(X["^")!(X="") D EXIT Q
S CPSTART=Y
K %DT,%DT("A"),X,Y
S Y=CPSTART D DD^%DT S CPSTART(0)=Y
;
S %DT="AE",%DT("A")="Enter Ending Date range: " D ^%DT
I (Y'>0)!(X["^")!(X="") D EXIT Q
S CPSEND=Y
K %DT,%DT("A"),X,Y
S Y=CPSEND D DD^%DT S OEND(0)=Y
S (CNT("UNIT DOSE","TR"),CNT("UNIT DOSE"))=0
K ^TMP($J)
P55 ; LOOP 55 UNIT DOSE
S CPSDATE=CPSTART F S CPSDATE=$O(^PS(55,"AUDS",CPSDATE)) Q:CPSDATE>CPSEND!('+CPSDATE) D
.S CPSDFN=0 F S CPSDFN=$O(^PS(55,"AUDS",CPSDATE,CPSDFN)) Q:'+CPSDFN D
..S CPS55=0 F S CPS55=$O(^PS(55,"AUDS",CPSDATE,CPSDFN,CPS55)) Q:'+CPS55 D
...;COUNT POSSIBLE DOSES DUE FOR ORDER.
...S CPSPOS=0
...S CPSFRE=$P($G(^PS(55,CPSDFN,5,+CPS55,2)),U,6),CPSTOP=$P($G(^PS(55,CPSDFN,5,+CPS55,2)),U,4),CPSSCH=$P($G(^PS(55,CPSDFN,5,+CPS55,0)),U,7)
...Q:CPSTOP<CPSDATE
...I CPSFRE="D"&(CPSSCH="C") S CPSN=$L($P($G(^PS(55,CPSDFN,5,+CPS55,2)),U,1),"-") S X2=CPSDATE,X1=$S(CPSTOP<DT:DT,1:CPSTOP) D ^%DTC S CPSPOS=CPSN*X
...I +CPSFRE&(CPSSCH="C") D
....S CPSS1=0,CPSS1=(24-$E($P(CPSDATE,".",2),1,2))*60 ;MINS FOR FIRST DATE
....IF CPSTOP>DT D NOW^%DTC S CPSS1=CPSS1+($E($P(%,".",2),1,2)*60) ; MINS FOR MIDNIGHT LAST DATE
....IF CPSTOP<DT S CPSS1=CPSS1+($E($P(CPSTOP,".",2),1,2)*60) ;MINS FOR MIDNIGHT LAST DATE
....S X1=CPSDATE,X2=+1 D C^%DTC S X2=X,X1=$S(CPSTOP>DT:DT,1:CPSTOP) D ^%DTC S CPSPOS=((X*1440)+CPSS1)/CPSFRE
....;S X1=DT,X2=+1 D C^%DTC S CPSNDT=X S X2=CPSDATE,X1=$S(CPSTOP>DT:CPSNDT,1:CPSTOP) D ^%DTC S CPSPOS=((X*1440)+CPSS1)/CPSFRE
...I CPSSCH="C"!(CPSSCH="P") S CNT("UNIT DOSE")=CNT("UNIT DOSE")+1
...;LOOK 53.79 FOR DOSE TRACKED.
...I CPSSCH="P" S CPSPOS=1 ;PRNS TO ONE
...Q:+CPSPOS<0!(CPSPOS=0)
...S CPSQ=$S(CPSSCH="P":1,CPSSCH="C":1,1:0)
...Q:CPSQ=0
...;W !,CPSSCH
...S (CPSPSB,CPSN1)=0 F S CPSN1=$O(^PSB(53.79,"AORDX",CPSDFN,CPS55_"U",CPSN1)) Q:'+CPSN1 S CPSPSB=CPSPSB+1
...Q:CPSPSB<CPSPOS
...S CNT("UNIT DOSE","TR")=CNT("UNIT DOSE","TR")+1 S ^TMP($J,"BCMA","TRUD",CPSDFN,CPS55)=CPSPOS_U_CPSPSB
...;W !,CPS55,U,CPSPOS,U,CPSPSB,U,CPSSCH
IV ;LOOP IVS
S (CNT("IV","TR"),CNT("IV"))=0
S CPSDATE=CPSTART F S CPSDATE=$O(^PS(55,"AIVS",CPSDATE)) Q:CPSDATE>CPSEND!('+CPSDATE) D
.S CPSDFN=0 F S CPSDFN=$O(^PS(55,"AIVS",CPSDATE,CPSDFN)) Q:'+CPSDFN D
..S CPS55=0 F S CPS55=$O(^PS(55,"AIVS",CPSDATE,CPSDFN,CPS55)) Q:'+CPS55 D
...S CNT("IV")=CNT("IV")+1,(CPSPSB,CPSPOS)=0
...S CPSTYPE=$P($G(^PS(55,CPSDFN,"IV",CPS55,0)),U,4)
...I CPSTYPE="P"!(CPSTYPE="S") D
....S CPSFRE=$P($G(^PS(55,CPSDFN,"IV",CPS55,0)),U,15) I +CPSFRE S CPSTOP=$P($G(^PS(55,CPSDFN,"IV",CPS55,0)),U,3) S X2=CPSDATE,X1=$S(CPSTOP<DT:DT,1:CPSTOP) D ^%DTC S CPSPOS=(X*1440)/CPSFRE
....I CPSFRE="O" S CPSPOS=1 ;ONCE
...;COUND TOTAL NUMBER OF IV BAGS FOR ORDER
...I $D(^PS(55,CPSDFN,"IV",+CPS55,"BCMA"))&(CPSTYPE'="P")&(CPSTYPE'="S") S (CPSPOS,CPSNUM)=0 F S CPSNUM=$O(^PS(55,CPSDFN,"IV",+CPS55,"BCMA",CPSNUM)) Q:'+CPSNUM S CPSPOS=CPSPOS+1
...;NO LABELS
...I '$D(^PS(55,CPSDFN,"IV",+CPS55,"BCMA"))&(CPSTYPE'="P")&(CPSTYPE'="S") D
....S CPSVOL=$P($G(^PS(55,CPSDFN,"IV",CPS55,"SOL",1,0)),U,2),CPSRAT=$P($G(^PS(55,CPSDFN,"IV",CPS55,0)),U,8)
....S CPSTOP=$P($G(^PS(55,CPSDFN,"IV",CPS55,0)),U,3)
....S CPSS1=0,CPSS1=(24-$E($P(CPSDATE,".",2),1,2))*60 ;MINS FOR FIRST DATE
....IF CPSTOP>DT D NOW^%DTC S CPSS1=CPSS1+($E($P(%,".",2),1,2)*60) ; MINS FOR MIDNIGHT LAST DATE
....IF CPSTOP<DT S CPSS1=CPSS1+($E($P(CPSTOP,".",2),1,2)*60) ;MINS FOR MIDNIGHT LAST DATE
....S X1=CPSDATE,X2=+1 D C^%DTC S X2=X,X1=$S(CPSTOP>DT:DT,1:CPSTOP) D ^%DTC S CPSPOS=(((((+CPSRAT*24)*X)+CPSS1)+CPSS1)\+CPSVOL)
...Q:'+CPSPOS&('+$G(CPSRAT)) ;NO POSSIBLE FOUND AND NO INFUSTION RATE BAIL THIS ONE.
...;LOOK IN BCMA FOR IVS
...S (CPSNUM,CPSPSB)=0 F S CPSNUM=$O(^PSB(53.79,"AUID",CPSDFN,CPS55_"V",CPSNUM)) Q:'+CPSNUM S CPSPSB=CPSPSB+1 D
....;W !,CPS55,U,CPSPOS,U,CPSPSB
....Q:CPSPSB<CPSPOS
....S CNT("IV","TR")=CNT("IV","TR")+1 S ^TMP($J,"BCMA","IV",CPSDFN,CPS55,CPSNUM)=CPSPOS_U_CPSPSB
..;NEXT FIND BCMA TOTAL MEDS GIVE ON UD AND MATCH IV ORDERS.
PRT ;
S (CNTT,CNTTR)=0
W !,?5,"Meaningfull Use Stage II Report From " S Y=CPSTART D DD^%DT W Y_" TO " S Y=CPSEND D DD^%DT W Y
D NOW^%DTC S Y=% D DD^%DT W !,?45,"Run Date/Time:"_Y
W !,"Order Type",?15,"Total Orders",?30," %100 Tracked"
W ! F J=1:1:IOM W "-"
W ! F I="UNIT DOSE","IV" W I,?17,$G(CNT(I)),?35,$G(CNT(I,"TR")),! S CNTT=CNTT+$G(CNT(I)),CNTTR=CNTTR+$G(CNT(I,"TR"))
W ! F J=1:1:IOM W "-"
W !,?17,CNTT,?35,CNTTR
EXIT ;
Q
APCMVAEM ; IHS/CMI/LAB - V2 MED BY PROV SUB RTN KFOX ;
+1 ;;1.0;IHS MU PERFORMANCE REPORTS;**5,6**;MAR 26, 2012;Build 65
START ;Set beginning/ending sort dates for ORDERS
+1 SET %DT="AE"
SET %DT("A")="Enter Start Date range: "
DO ^%DT
+2 IF (Y'>0)!(X["^")!(X="")
DO EXIT
QUIT
+3 SET CPSTART=Y
+4 KILL %DT,%DT("A"),X,Y
+5 SET Y=CPSTART
DO DD^%DT
SET CPSTART(0)=Y
+6 ;
+7 SET %DT="AE"
SET %DT("A")="Enter Ending Date range: "
DO ^%DT
+8 IF (Y'>0)!(X["^")!(X="")
DO EXIT
QUIT
+9 SET CPSEND=Y
+10 KILL %DT,%DT("A"),X,Y
+11 SET Y=CPSEND
DO DD^%DT
SET OEND(0)=Y
+12 SET (CNT("UNIT DOSE","TR"),CNT("UNIT DOSE"))=0
+13 KILL ^TMP($JOB)
P55 ; LOOP 55 UNIT DOSE
+1 SET CPSDATE=CPSTART
FOR
SET CPSDATE=$ORDER(^PS(55,"AUDS",CPSDATE))
IF CPSDATE>CPSEND!('+CPSDATE)
QUIT
Begin DoDot:1
+2 SET CPSDFN=0
FOR
SET CPSDFN=$ORDER(^PS(55,"AUDS",CPSDATE,CPSDFN))
IF '+CPSDFN
QUIT
Begin DoDot:2
+3 SET CPS55=0
FOR
SET CPS55=$ORDER(^PS(55,"AUDS",CPSDATE,CPSDFN,CPS55))
IF '+CPS55
QUIT
Begin DoDot:3
+4 ;COUNT POSSIBLE DOSES DUE FOR ORDER.
+5 SET CPSPOS=0
+6 SET CPSFRE=$PIECE($GET(^PS(55,CPSDFN,5,+CPS55,2)),U,6)
SET CPSTOP=$PIECE($GET(^PS(55,CPSDFN,5,+CPS55,2)),U,4)
SET CPSSCH=$PIECE($GET(^PS(55,CPSDFN,5,+CPS55,0)),U,7)
+7 IF CPSTOP<CPSDATE
QUIT
+8 IF CPSFRE="D"&(CPSSCH="C")
SET CPSN=$LENGTH($PIECE($GET(^PS(55,CPSDFN,5,+CPS55,2)),U,1),"-")
SET X2=CPSDATE
SET X1=$SELECT(CPSTOP<DT:DT,1:CPSTOP)
DO ^%DTC
SET CPSPOS=CPSN*X
+9 IF +CPSFRE&(CPSSCH="C")
Begin DoDot:4
+10 ;MINS FOR FIRST DATE
SET CPSS1=0
SET CPSS1=(24-$EXTRACT($PIECE(CPSDATE,".",2),1,2))*60
+11 ; MINS FOR MIDNIGHT LAST DATE
IF CPSTOP>DT
DO NOW^%DTC
SET CPSS1=CPSS1+($EXTRACT($PIECE(%,".",2),1,2)*60)
+12 ;MINS FOR MIDNIGHT LAST DATE
IF CPSTOP<DT
SET CPSS1=CPSS1+($EXTRACT($PIECE(CPSTOP,".",2),1,2)*60)
+13 SET X1=CPSDATE
SET X2=+1
DO C^%DTC
SET X2=X
SET X1=$SELECT(CPSTOP>DT:DT,1:CPSTOP)
DO ^%DTC
SET CPSPOS=((X*1440)+CPSS1)/CPSFRE
+14 ;S X1=DT,X2=+1 D C^%DTC S CPSNDT=X S X2=CPSDATE,X1=$S(CPSTOP>DT:CPSNDT,1:CPSTOP) D ^%DTC S CPSPOS=((X*1440)+CPSS1)/CPSFRE
End DoDot:4
+15 IF CPSSCH="C"!(CPSSCH="P")
SET CNT("UNIT DOSE")=CNT("UNIT DOSE")+1
+16 ;LOOK 53.79 FOR DOSE TRACKED.
+17 ;PRNS TO ONE
IF CPSSCH="P"
SET CPSPOS=1
+18 IF +CPSPOS<0!(CPSPOS=0)
QUIT
+19 SET CPSQ=$SELECT(CPSSCH="P":1,CPSSCH="C":1,1:0)
+20 IF CPSQ=0
QUIT
+21 ;W !,CPSSCH
+22 SET (CPSPSB,CPSN1)=0
FOR
SET CPSN1=$ORDER(^PSB(53.79,"AORDX",CPSDFN,CPS55_"U",CPSN1))
IF '+CPSN1
QUIT
SET CPSPSB=CPSPSB+1
+23 IF CPSPSB<CPSPOS
QUIT
+24 SET CNT("UNIT DOSE","TR")=CNT("UNIT DOSE","TR")+1
SET ^TMP($JOB,"BCMA","TRUD",CPSDFN,CPS55)=CPSPOS_U_CPSPSB
+25 ;W !,CPS55,U,CPSPOS,U,CPSPSB,U,CPSSCH
End DoDot:3
End DoDot:2
End DoDot:1
IV ;LOOP IVS
+1 SET (CNT("IV","TR"),CNT("IV"))=0
+2 SET CPSDATE=CPSTART
FOR
SET CPSDATE=$ORDER(^PS(55,"AIVS",CPSDATE))
IF CPSDATE>CPSEND!('+CPSDATE)
QUIT
Begin DoDot:1
+3 SET CPSDFN=0
FOR
SET CPSDFN=$ORDER(^PS(55,"AIVS",CPSDATE,CPSDFN))
IF '+CPSDFN
QUIT
Begin DoDot:2
+4 SET CPS55=0
FOR
SET CPS55=$ORDER(^PS(55,"AIVS",CPSDATE,CPSDFN,CPS55))
IF '+CPS55
QUIT
Begin DoDot:3
+5 SET CNT("IV")=CNT("IV")+1
SET (CPSPSB,CPSPOS)=0
+6 SET CPSTYPE=$PIECE($GET(^PS(55,CPSDFN,"IV",CPS55,0)),U,4)
+7 IF CPSTYPE="P"!(CPSTYPE="S")
Begin DoDot:4
+8 SET CPSFRE=$PIECE($GET(^PS(55,CPSDFN,"IV",CPS55,0)),U,15)
IF +CPSFRE
SET CPSTOP=$PIECE($GET(^PS(55,CPSDFN,"IV",CPS55,0)),U,3)
SET X2=CPSDATE
SET X1=$SELECT(CPSTOP<DT:DT,1:CPSTOP)
DO ^%DTC
SET CPSPOS=(X*1440)/CPSFRE
+9 ;ONCE
IF CPSFRE="O"
SET CPSPOS=1
End DoDot:4
+10 ;COUND TOTAL NUMBER OF IV BAGS FOR ORDER
+11 IF $DATA(^PS(55,CPSDFN,"IV",+CPS55,"BCMA"))&(CPSTYPE'="P")&(CPSTYPE'="S")
SET (CPSPOS,CPSNUM)=0
FOR
SET CPSNUM=$ORDER(^PS(55,CPSDFN,"IV",+CPS55,"BCMA",CPSNUM))
IF '+CPSNUM
QUIT
SET CPSPOS=CPSPOS+1
+12 ;NO LABELS
+13 IF '$DATA(^PS(55,CPSDFN,"IV",+CPS55,"BCMA"))&(CPSTYPE'="P")&(CPSTYPE'="S")
Begin DoDot:4
+14 SET CPSVOL=$PIECE($GET(^PS(55,CPSDFN,"IV",CPS55,"SOL",1,0)),U,2)
SET CPSRAT=$PIECE($GET(^PS(55,CPSDFN,"IV",CPS55,0)),U,8)
+15 SET CPSTOP=$PIECE($GET(^PS(55,CPSDFN,"IV",CPS55,0)),U,3)
+16 ;MINS FOR FIRST DATE
SET CPSS1=0
SET CPSS1=(24-$EXTRACT($PIECE(CPSDATE,".",2),1,2))*60
+17 ; MINS FOR MIDNIGHT LAST DATE
IF CPSTOP>DT
DO NOW^%DTC
SET CPSS1=CPSS1+($EXTRACT($PIECE(%,".",2),1,2)*60)
+18 ;MINS FOR MIDNIGHT LAST DATE
IF CPSTOP<DT
SET CPSS1=CPSS1+($EXTRACT($PIECE(CPSTOP,".",2),1,2)*60)
+19 SET X1=CPSDATE
SET X2=+1
DO C^%DTC
SET X2=X
SET X1=$SELECT(CPSTOP>DT:DT,1:CPSTOP)
DO ^%DTC
SET CPSPOS=(((((+CPSRAT*24)*X)+CPSS1)+CPSS1)\+CPSVOL)
End DoDot:4
+20 ;NO POSSIBLE FOUND AND NO INFUSTION RATE BAIL THIS ONE.
IF '+CPSPOS&('+$GET(CPSRAT))
QUIT
+21 ;LOOK IN BCMA FOR IVS
+22 SET (CPSNUM,CPSPSB)=0
FOR
SET CPSNUM=$ORDER(^PSB(53.79,"AUID",CPSDFN,CPS55_"V",CPSNUM))
IF '+CPSNUM
QUIT
SET CPSPSB=CPSPSB+1
Begin DoDot:4
+23 ;W !,CPS55,U,CPSPOS,U,CPSPSB
+24 IF CPSPSB<CPSPOS
QUIT
+25 SET CNT("IV","TR")=CNT("IV","TR")+1
SET ^TMP($JOB,"BCMA","IV",CPSDFN,CPS55,CPSNUM)=CPSPOS_U_CPSPSB
End DoDot:4
End DoDot:3
+26 ;NEXT FIND BCMA TOTAL MEDS GIVE ON UD AND MATCH IV ORDERS.
End DoDot:2
End DoDot:1
PRT ;
+1 SET (CNTT,CNTTR)=0
+2 WRITE !,?5,"Meaningfull Use Stage II Report From "
SET Y=CPSTART
DO DD^%DT
WRITE Y_" TO "
SET Y=CPSEND
DO DD^%DT
WRITE Y
+3 DO NOW^%DTC
SET Y=%
DO DD^%DT
WRITE !,?45,"Run Date/Time:"_Y
+4 WRITE !,"Order Type",?15,"Total Orders",?30," %100 Tracked"
+5 WRITE !
FOR J=1:1:IOM
WRITE "-"
+6 WRITE !
FOR I="UNIT DOSE","IV"
WRITE I,?17,$GET(CNT(I)),?35,$GET(CNT(I,"TR")),!
SET CNTT=CNTT+$GET(CNT(I))
SET CNTTR=CNTTR+$GET(CNT(I,"TR"))
+7 WRITE !
FOR J=1:1:IOM
WRITE "-"
+8 WRITE !,?17,CNTT,?35,CNTTR
EXIT ;
+1 QUIT
