APSPDRP1 ; IHS/DSD/ENM - PRINT DUE REVIEW REPORT ; [ 09/03/97 1:30 PM ]
;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97
; This routine is responsible for getting the information to
; print and doing the formatting of the report.
; The routine calls APSDRP2 to do the actual printing. I had to
; break up the routine because of its size.
;
; Input Variables: APSPDRP("BD"),APSPDRP("ED"),APSPDRP("IOP"),
; ^TMP("APSPDRP1",$J,
;-----------------------------------------------------------------
START ;
S (DX,DY)=1 X:$D(^%ZOSF("XY"))#2 ^("XY")
I '$D(ZTSK),$P(APSPDRP("IOP"),";",1)'=ION S IOP=APSPDRP("IOP") D ^%ZIS U IO
ELSE U IO
D BODY
END D EOJ
Q
;------------------------------------------------------------------
BODY ;
F APSPDRP1("STUDY")=0:0 S APSPDRP1("STUDY")=$O(^TMP("APSPDRP1",$J,APSPDRP1("STUDY"))) Q:'APSPDRP1("STUDY")!($D(APSPDRP1("QFLG"))) D INIT,HEADER,^APSPDRP2 D:'$D(APSPDRP1("QFLG")) TOTAL
D ^%ZISC
Q
INIT ;
S APSPDRP1("STUDY CNT")=0 K APSPDRP1("STUDY CR")
F APSPI=0:0 S APSPI=$O(^APSPDUE(32.1,APSPDRP1("STUDY"),11,APSPI)) Q:'APSPI S APSPDRP1("STUDY CR",$P(^APSPDUE(32.2,APSPI,0),U,1))="",APSPDRP1("STUDY CNT")=APSPDRP1("STUDY CNT")+1
S APSPDRP1("CR LF")=((APSPDRP1("STUDY CNT")*6)/(IOM-68))
S:APSPDRP1("CR LF")["." APSPDRP1("CR LF")=$P(APSPDRP1("CR LF"),".",1)+1
K APSPI
K APSPDRP1("YES CNT")
S (APSPDRP1("CNT"),APSPDRP1("ALL MET CNT"))=0
S APSPDRP1("PAGE")=0
Q
S APSPDRP1("PAGE")=APSPDRP1("PAGE")+1
I $D(DUZ(2)) W !!,$P(^DIC(4,DUZ(2),0),"^",1)," ",$P(^APSPDUE(32.1,APSPDRP1("STUDY"),0),U,1)," STUDY REPORT"
I '$D(DUZ(2)) W !!,$P(^APSPDUE(32.1,APSPDRP1("STUDY"),0),U,1)," STUDY REPORT"
W ?73,"Page ",APSPDRP1("PAGE")
W !,"DATE OF REPORT: "
S Y=DT X ^DD("DD") W Y K Y
W !!,"This report will include all DUE review entries "
W "from ",!
S Y=APSPDRP("BD") X ^DD("DD") W Y," through " K Y
S Y=$P(APSPDRP("ED"),".",1) X ^DD("DD") W Y,".",!!
W !,?69,"CRITERIA",?(IOM-3),"ALL"
W !,?69,"MET",?(IOM-3),"MET",!
W !,"DATE",?15,"PATIENT",?40,"PROVIDER",?62 D
. F APSPII=0:0 S APSPII=$O(APSPDRP1("STUDY CR",APSPII)) Q:'APSPII W:$X+12>IOM !,?62 W ?($X+3),APSPII I $L(APSPII)<3 W $S($L(APSPII)<2:" ",1:" ")
K APSPII
W ! F I=1:1:(IOM) W "_"
W !
Q
TOTAL ; Prints totals from Report
I $E(IOST,1,2)="P-",($Y+6+APSPDRP1("CR LF"))>IOSL W @IOF D HEADER
I $E(IOST,1,2)'="P-",($Y+6+APSPDRP1("CR LF"))>IOSL D EOP G:$D(APSPDRP1("QFLG")) TOTALX
W !
W ! F I=1:1:(IOM) W "_"
W !
W !,"TOTAL",?62
F APSPII=0:0 S APSPII=$O(APSPDRP1("YES CNT",APSPII)) Q:'APSPII W:$X+12>IOM !,?62 W ?($X+3),APSPDRP1("YES CNT",APSPII) I $L(APSPII)<3 W $S($L(APSPII)<2:" ",1:" ")
W ?(IOM-3),APSPDRP1("ALL MET CNT")
W !,"COUNT",?15,APSPDRP1("CNT")
W !
I $E(IOST,1,2)="P-" W @IOF
TOTALX Q
;
EOP ; Calls reader for an End of Page call
S DIR(0)="E" D ^DIR K DIR,X,Y
S:$D(DTOUT)!($D(DUOUT)) APSPDRP1("QFLG")=1
S (DX,DY)=1 X:$D(^%ZOSF("XY"))#2 ^("XY")
Q
EOJ ;
K:$D(ZTSK) ZTSK ;IHS/DSD/ENM 01/14/97
K APSPDRP1,^TMP("APSPDRP1",$J),DTOUT,DUOUT,DIR,DIRUT
Q
;
APSPDRP1 ; IHS/DSD/ENM - PRINT DUE REVIEW REPORT ; [ 09/03/97 1:30 PM ]
+1 ;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97
+2 ; This routine is responsible for getting the information to
+3 ; print and doing the formatting of the report.
+4 ; The routine calls APSDRP2 to do the actual printing. I had to
+5 ; break up the routine because of its size.
+6 ;
+7 ; Input Variables: APSPDRP("BD"),APSPDRP("ED"),APSPDRP("IOP"),
+8 ; ^TMP("APSPDRP1",$J,
+9 ;-----------------------------------------------------------------
START ;
+1 SET (DX,DY)=1
IF $DATA(^%ZOSF("XY"))#2
XECUTE ^("XY")
+2 IF '$DATA(ZTSK)
IF $PIECE(APSPDRP("IOP"),";",1)'=ION
SET IOP=APSPDRP("IOP")
DO ^%ZIS
USE IO
+3 IF '$TEST
USE IO
+4 DO BODY
END DO EOJ
+1 QUIT
+2 ;------------------------------------------------------------------
BODY ;
+1 FOR APSPDRP1("STUDY")=0:0
SET APSPDRP1("STUDY")=$ORDER(^TMP("APSPDRP1",$JOB,APSPDRP1("STUDY")))
IF 'APSPDRP1("STUDY")!($DATA(APSPDRP1("QFLG")))
QUIT
DO INIT
DO HEADER
DO ^APSPDRP2
IF '$DATA(APSPDRP1("QFLG"))
DO TOTAL
+2 DO ^%ZISC
+3 QUIT
INIT ;
+1 SET APSPDRP1("STUDY CNT")=0
KILL APSPDRP1("STUDY CR")
+2 FOR APSPI=0:0
SET APSPI=$ORDER(^APSPDUE(32.1,APSPDRP1("STUDY"),11,APSPI))
IF 'APSPI
QUIT
SET APSPDRP1("STUDY CR",$PIECE(^APSPDUE(32.2,APSPI,0),U,1))=""
SET APSPDRP1("STUDY CNT")=APSPDRP1("STUDY CNT")+1
+3 SET APSPDRP1("CR LF")=((APSPDRP1("STUDY CNT")*6)/(IOM-68))
+4 IF APSPDRP1("CR LF")["."
SET APSPDRP1("CR LF")=$PIECE(APSPDRP1("CR LF"),".",1)+1
+5 KILL APSPI
+6 KILL APSPDRP1("YES CNT")
+7 SET (APSPDRP1("CNT"),APSPDRP1("ALL MET CNT"))=0
+8 SET APSPDRP1("PAGE")=0
+9 QUIT
+1 SET APSPDRP1("PAGE")=APSPDRP1("PAGE")+1
+2 IF $DATA(DUZ(2))
WRITE !!,$PIECE(^DIC(4,DUZ(2),0),"^",1)," ",$PIECE(^APSPDUE(32.1,APSPDRP1("STUDY"),0),U,1)," STUDY REPORT"
+3 IF '$DATA(DUZ(2))
WRITE !!,$PIECE(^APSPDUE(32.1,APSPDRP1("STUDY"),0),U,1)," STUDY REPORT"
+4 WRITE ?73,"Page ",APSPDRP1("PAGE")
+5 WRITE !,"DATE OF REPORT: "
+6 SET Y=DT
XECUTE ^DD("DD")
WRITE Y
KILL Y
+7 WRITE !!,"This report will include all DUE review entries "
+8 WRITE "from ",!
+9 SET Y=APSPDRP("BD")
XECUTE ^DD("DD")
WRITE Y," through "
KILL Y
+10 SET Y=$PIECE(APSPDRP("ED"),".",1)
XECUTE ^DD("DD")
WRITE Y,".",!!
+11 WRITE !,?69,"CRITERIA",?(IOM-3),"ALL"
+12 WRITE !,?69,"MET",?(IOM-3),"MET",!
+13 WRITE !,"DATE",?15,"PATIENT",?40,"PROVIDER",?62
Begin DoDot:1
+14 FOR APSPII=0:0
SET APSPII=$ORDER(APSPDRP1("STUDY CR",APSPII))
IF 'APSPII
QUIT
IF $X+12>IOM
WRITE !,?62
WRITE ?($X+3),APSPII
IF $LENGTH(APSPII)<3
WRITE $SELECT($LENGTH(APSPII)<2:" ",1:" ")
End DoDot:1
+15 KILL APSPII
+16 WRITE !
FOR I=1:1:(IOM)
WRITE "_"
+17 WRITE !
+18 QUIT
TOTAL ; Prints totals from Report
+1 IF $EXTRACT(IOST,1,2)="P-"
IF ($Y+6+APSPDRP1("CR LF"))>IOSL
WRITE @IOF
DO HEADER
+2 IF $EXTRACT(IOST,1,2)'="P-"
IF ($Y+6+APSPDRP1("CR LF"))>IOSL
DO EOP
IF $DATA(APSPDRP1("QFLG"))
GOTO TOTALX
+3 WRITE !
+4 WRITE !
FOR I=1:1:(IOM)
WRITE "_"
+5 WRITE !
+6 WRITE !,"TOTAL",?62
+7 FOR APSPII=0:0
SET APSPII=$ORDER(APSPDRP1("YES CNT",APSPII))
IF 'APSPII
QUIT
IF $X+12>IOM
WRITE !,?62
WRITE ?($X+3),APSPDRP1("YES CNT",APSPII)
IF $LENGTH(APSPII)<3
WRITE $SELECT($LENGTH(APSPII)<2:" ",1:" ")
+8 WRITE ?(IOM-3),APSPDRP1("ALL MET CNT")
+9 WRITE !,"COUNT",?15,APSPDRP1("CNT")
+10 WRITE !
+11 IF $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
TOTALX QUIT
+1 ;
EOP ; Calls reader for an End of Page call
+1 SET DIR(0)="E"
DO ^DIR
KILL DIR,X,Y
+2 IF $DATA(DTOUT)!($DATA(DUOUT))
SET APSPDRP1("QFLG")=1
+3 SET (DX,DY)=1
IF $DATA(^%ZOSF("XY"))#2
XECUTE ^("XY")
+4 QUIT
EOJ ;
+1 ;IHS/DSD/ENM 01/14/97
IF $DATA(ZTSK)
KILL ZTSK
+2 KILL APSPDRP1,^TMP("APSPDRP1",$JOB),DTOUT,DUOUT,DIR,DIRUT
+3 QUIT
+4 ;
