APSPDRP2 ; IHS/DSD/ENM - CONTINUATION OF APSPDRP1 ; [ 09/03/97 1:30 PM ]
;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97
; IHS/OHPRD/JCM 10/17/90 Changed PRINT+9 $P(APSPDRP1(0)) to 4 from 2
;
; Had to break up APSPDRP1 because of its size
; This routine should not be called by any other routine than
; APSPDRP1
;--------------------------------------------------------------------
START ;
Q:'$D(APSPDRP1)
S APSPDRP2=""
F APSPDRP1("DATE")=0:0 S APSPDRP1("DATE")=$O(^TMP("APSPDRP1",$J,APSPDRP1("STUDY"),APSPDRP1("DATE"))) Q:'APSPDRP1("DATE")!($D(APSPDRP1("QFLG"))) D PROV
K APSPDRP2
END Q
;_____________________________________________________________________
PROV ;
F APSPDRP1("PROV")=0:0 S APSPDRP1("PROV")=$O(^TMP("APSPDRP1",$J,APSPDRP1("STUDY"),APSPDRP1("DATE"),APSPDRP1("PROV"))) Q:'APSPDRP1("PROV")!($D(APSPDRP1("QFLG"))) D DA
Q
DA ;
F APSPDRP1("DA")=0:0 S APSPDRP1("DA")=$O(^TMP("APSPDRP1",$J,APSPDRP1("STUDY"),APSPDRP1("DATE"),APSPDRP1("PROV"),APSPDRP1("DA"))) Q:'APSPDRP1("DA")!($D(APSPDRP1("QFLG"))) D PRINT
Q
PRINT ;
S APSPDRP1("REM CNT")=0
I $D(^APSPDUE(32,APSPDRP1("DA"),12)) F APSPIII=0:0 S APSPIII=$O(^APSPDUE(32,APSPDRP1("DA"),12,APSPIII)) Q:'APSPIII S APSPDRP1("REM LINE",APSPIII)=^APSPDUE(32,APSPDRP1("DA"),12,APSPIII,0),APSPDRP1("REM CNT")=APSPDRP1("REM CNT")+1
I $E(IOST,1,2)="P-",($Y+1+APSPDRP1("CR LF")+APSPDRP1("REM CNT"))>IOSL W @IOF D HEADER^APSPDRP1
I $E(IOST,1,2)'="P-",($Y+1+APSPDRP1("CR LF")+APSPDRP1("REM CNT"))>IOSL D EOP G:$D(APSPDRP1("QFLG")) PRINTX
W !
S APSPDRP1(0)=^APSPDUE(32,APSPDRP1("DA"),0)
S Y=$P(APSPDRP1(0),U,1) X ^DD("DD")
W Y K Y
W ?15,$E($P(^DPT($P(APSPDRP1(0),U,4),0),U,1),1,25) ;IHS/OHPRD/JCM 10/17/90
W ?40,$E($P(^DIC(16,$P(APSPDRP1(0),U,6),0),U,1),1,25)
W ?62
F APSPI=0:0 S APSPI=$O(^APSPDUE(32,APSPDRP1("DA"),11,APSPI)) Q:'APSPI S APSPDRP1("CR",$P(^APSPDUE(32.2,APSPI,0),U,1))=^APSPDUE(32,APSPDRP1("DA"),11,APSPI,0)
F APSPII=0:0 S APSPII=$O(APSPDRP1("CR",APSPII)) Q:'APSPII W:$X+12>IOM !,?62 W ?($X+3),$S($P(APSPDRP1("CR",APSPII),U,2)=0:"NO",$P(APSPDRP1("CR",APSPII),U,2)=1:"YES",1:"UN") D
. S:'$D(APSPDRP1("YES CNT",APSPII)) APSPDRP1("YES CNT",APSPII)=0
. S:$P(APSPDRP1("CR",APSPII),U,2) APSPDRP1("YES CNT",APSPII)=(APSPDRP1("YES CNT",APSPII)+1)
W ?(IOM-3),$S('$P(APSPDRP1(0),U,8):"NO",1:"YES") S:$P(APSPDRP1(0),U,8) APSPDRP1("ALL MET CNT")=(APSPDRP1("ALL MET CNT")+1)
I $D(APSPDRP1("REM LINE")) W !,"Remarks: " F APSPIIII=1:1:APSPDRP1("REM CNT") W:APSPIIII=1&($X+$L(APSPDRP1("REM LINE",APSPIIII))>IOM) ! W:APSPIIII'=1 ! W APSPDRP1("REM LINE",APSPIIII)
W !
S APSPDRP1("CNT")=(APSPDRP1("CNT")+1)
PRINTX K APSPDRP1("CR"),APSPDRP1(0),APSPI,APSPII,APSPIII,APSPDRP1("REM LINE")
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
APSPDRP2 ; IHS/DSD/ENM - CONTINUATION OF APSPDRP1 ; [ 09/03/97 1:30 PM ]
+1 ;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97
+2 ; IHS/OHPRD/JCM 10/17/90 Changed PRINT+9 $P(APSPDRP1(0)) to 4 from 2
+3 ;
+4 ; Had to break up APSPDRP1 because of its size
+5 ; This routine should not be called by any other routine than
+6 ; APSPDRP1
+7 ;--------------------------------------------------------------------
START ;
+1 IF '$DATA(APSPDRP1)
QUIT
+2 SET APSPDRP2=""
+3 FOR APSPDRP1("DATE")=0:0
SET APSPDRP1("DATE")=$ORDER(^TMP("APSPDRP1",$JOB,APSPDRP1("STUDY"),APSPDRP1("DATE")))
IF 'APSPDRP1("DATE")!($DATA(APSPDRP1("QFLG")))
QUIT
DO PROV
+4 KILL APSPDRP2
END QUIT
+1 ;_____________________________________________________________________
PROV ;
+1 FOR APSPDRP1("PROV")=0:0
SET APSPDRP1("PROV")=$ORDER(^TMP("APSPDRP1",$JOB,APSPDRP1("STUDY"),APSPDRP1("DATE"),APSPDRP1("PROV")))
IF 'APSPDRP1("PROV")!($DATA(APSPDRP1("QFLG")))
QUIT
DO DA
+2 QUIT
DA ;
+1 FOR APSPDRP1("DA")=0:0
SET APSPDRP1("DA")=$ORDER(^TMP("APSPDRP1",$JOB,APSPDRP1("STUDY"),APSPDRP1("DATE"),APSPDRP1("PROV"),APSPDRP1("DA")))
IF 'APSPDRP1("DA")!($DATA(APSPDRP1("QFLG")))
QUIT
DO PRINT
+2 QUIT
PRINT ;
+1 SET APSPDRP1("REM CNT")=0
+2 IF $DATA(^APSPDUE(32,APSPDRP1("DA"),12))
FOR APSPIII=0:0
SET APSPIII=$ORDER(^APSPDUE(32,APSPDRP1("DA"),12,APSPIII))
IF 'APSPIII
QUIT
SET APSPDRP1("REM LINE",APSPIII)=^APSPDUE(32,APSPDRP1("DA"),12,APSPIII,0)
SET APSPDRP1("REM CNT")=APSPDRP1("REM CNT")+1
+3 IF $EXTRACT(IOST,1,2)="P-"
IF ($Y+1+APSPDRP1("CR LF")+APSPDRP1("REM CNT"))>IOSL
WRITE @IOF
DO HEADER^APSPDRP1
+4 IF $EXTRACT(IOST,1,2)'="P-"
IF ($Y+1+APSPDRP1("CR LF")+APSPDRP1("REM CNT"))>IOSL
DO EOP
IF $DATA(APSPDRP1("QFLG"))
GOTO PRINTX
+5 WRITE !
+6 SET APSPDRP1(0)=^APSPDUE(32,APSPDRP1("DA"),0)
+7 SET Y=$PIECE(APSPDRP1(0),U,1)
XECUTE ^DD("DD")
+8 WRITE Y
KILL Y
+9 ;IHS/OHPRD/JCM 10/17/90
WRITE ?15,$EXTRACT($PIECE(^DPT($PIECE(APSPDRP1(0),U,4),0),U,1),1,25)
+10 WRITE ?40,$EXTRACT($PIECE(^DIC(16,$PIECE(APSPDRP1(0),U,6),0),U,1),1,25)
+11 WRITE ?62
+12 FOR APSPI=0:0
SET APSPI=$ORDER(^APSPDUE(32,APSPDRP1("DA"),11,APSPI))
IF 'APSPI
QUIT
SET APSPDRP1("CR",$PIECE(^APSPDUE(32.2,APSPI,0),U,1))=^APSPDUE(32,APSPDRP1("DA"),11,APSPI,0)
+13 FOR APSPII=0:0
SET APSPII=$ORDER(APSPDRP1("CR",APSPII))
IF 'APSPII
QUIT
IF $X+12>IOM
WRITE !,?62
WRITE ?($X+3),$SELECT($PIECE(APSPDRP1("CR",APSPII),U,2)=0:"NO",$PIECE(APSPDRP1("CR",APSPII),U,2)=1:"YES",1:"UN")
Begin DoDot:1
+14 IF '$DATA(APSPDRP1("YES CNT",APSPII))
SET APSPDRP1("YES CNT",APSPII)=0
+15 IF $PIECE(APSPDRP1("CR",APSPII),U,2)
SET APSPDRP1("YES CNT",APSPII)=(APSPDRP1("YES CNT",APSPII)+1)
End DoDot:1
+16 WRITE ?(IOM-3),$SELECT('$PIECE(APSPDRP1(0),U,8):"NO",1:"YES")
IF $PIECE(APSPDRP1(0),U,8)
SET APSPDRP1("ALL MET CNT")=(APSPDRP1("ALL MET CNT")+1)
+17 IF $DATA(APSPDRP1("REM LINE"))
WRITE !,"Remarks: "
FOR APSPIIII=1:1:APSPDRP1("REM CNT")
IF APSPIIII=1&($X+$LENGTH(APSPDRP1("REM LINE",APSPIIII))>IOM)
WRITE !
IF APSPIIII'=1
WRITE !
WRITE APSPDRP1("REM LINE",APSPIIII)
+18 WRITE !
+19 SET APSPDRP1("CNT")=(APSPDRP1("CNT")+1)
PRINTX KILL APSPDRP1("CR"),APSPDRP1(0),APSPI,APSPII,APSPIII,APSPDRP1("REM LINE")
+1 QUIT
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
