Routine: APSPDRP2

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

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

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")

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")

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

APSPDRP2.m