APSPMED3.m

APSPMED3 ; IHS/DSD/ENM - PRINTS SHORT MEDICATION PROFILE ;  [ 09/03/97   1:30 PM ]

 ;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97

 K RX,DTOUT,DIRUT,DIROUT,DUOUT

 D HD S DRUG="" F I=0:0 S DRUG=$O(^TMP($J,DRUG)) Q:DRUG=""  F J=0:0 S J=$O(^TMP($J,DRUG,J)) Q:'J!($D(DTOUT))!($D(DUOUT))!($D(DIROUT))  S RX0=^(J),RX2=$G(^PSRX(J,2)),ST=+$P(RX0,"^",15) S:$P(RX2,"^",15) RST($P(RX2,"^",2))=1 D W

 Q

Q ;D ^%ZISC K ^TMP($J),PSODTCT,ST,D0,DIC,DIR,DIRUT,DUOUT,G,II,K,RXD,RXF,ZX,DRUG,X,DFN,PHYS,PSRT,CT,AL,I1,PLS,REF,LMI,PI,FN,Y,I,J,RX,DRX,ST,RX0,RX2,DA S:$D(ZTQUEUED) ZTREQ="@" Q

 Q

W ;I $Y+4>IOSL,IOST["C-" S DIR("A")="ENTER '^' TO HALT",DIR(0)="FO" D ^DIR Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))  W @IOF

 I $Y+4>IOSL,IOST["C-" S DIR("A")="ENTER '^' TO HALT",DIR(0)="E" D ^DIR Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))  W @IOF D HD ;IHS/DSD/ENM 02/20/97

 ;U IO I IO'=IO(0),$Y+4>IOSL W @IOF

 D STAT^PSOFUNC W !,$P(RX0,"^"),?8,$S(PSRT="DRUG":DRUG,$D(^PSDRUG(+$P(RX0,"^",6),0)):$P(^(0),"^"),1:"NOT ON FILE"),?44,$E(ST,1),?47,$J($P(RX0,"^",7),6)

 S RXD=$P(^PSRX(J,3),"^"),RXF=$P(RX0,"^",9) F II=0:0 S II=$O(^PSRX(J,1,II)) Q:'II  S RXF=RXF-1 S:$P(^PSRX(J,1,II,0),"^",16) RST($P(^(0),"^"))=1

 W ?55,$E($P(RX0,"^",13),4,5)_"-"_$E($P(RX0,"^",13),6,7)_"-"_$E($P(RX0,"^",13),2,3) W:RXD ?65,$E(RXD,4,5)_"-"_$E(RXD,6,7)_"-"_$E(RXD,2,3)_$S($G(RST(RXD)):"R",1:"") W ?75,"("_RXF_")"

 W !?10,$P(RX0,"^",10) K RST Q

HD U IO W !!,"RX#     DRUG",?42,"STAT    QTY",?55,"ISSUED ",?65,"LAST FILL REM"

 Q

APSPMED3  ; IHS/DSD/ENM - PRINTS SHORT MEDICATION PROFILE ;  [ 09/03/97   1:30 PM ]

 +1       ;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97

 +2        KILL RX,DTOUT,DIRUT,DIROUT,DUOUT

 +3        DO HD

           SET DRUG=""

           FOR I=0:0

               SET DRUG=$ORDER(^TMP($JOB,DRUG))

               IF DRUG=""

                   QUIT 

               FOR J=0:0

                   SET J=$ORDER(^TMP($JOB,DRUG,J))

                   IF 'J!($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIROUT))

                       QUIT 

                   SET RX0=^(J)

                   SET RX2=$GET(^PSRX(J,2))

                   SET ST=+$PIECE(RX0,"^",15)

                   IF $PIECE(RX2,"^",15)

                       SET RST($PIECE(RX2,"^",2))=1

                   DO W

 +4        QUIT 

Q         ;D ^%ZISC K ^TMP($J),PSODTCT,ST,D0,DIC,DIR,DIRUT,DUOUT,G,II,K,RXD,RXF,ZX,DRUG,X,DFN,PHYS,PSRT,CT,AL,I1,PLS,REF,LMI,PI,FN,Y,I,J,RX,DRX,ST,RX0,RX2,DA S:$D(ZTQUEUED) ZTREQ="@" Q

 +1        QUIT 

W         ;I $Y+4>IOSL,IOST["C-" S DIR("A")="ENTER '^' TO HALT",DIR(0)="FO" D ^DIR Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))  W @IOF

 +1       ;IHS/DSD/ENM 02/20/97

           IF $Y+4>IOSL

               IF IOST["C-"

                   SET DIR("A")="ENTER '^' TO HALT"

                   SET DIR(0)="E"

                   DO ^DIR

                   IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))

                       QUIT 

                   WRITE @IOF

                   DO HD

 +2       ;U IO I IO'=IO(0),$Y+4>IOSL W @IOF

 +3        DO STAT^PSOFUNC

           WRITE !,$PIECE(RX0,"^"),?8,$SELECT(PSRT="DRUG":DRUG,$DATA(^PSDRUG(+$PIECE(RX0,"^",6),0)):$PIECE(^(0),"^"),1:"NOT ON FILE"),?44,$EXTRACT(ST,1),?47,$JUSTIFY($PIECE(RX0,"^",7),6)

 +4        SET RXD=$PIECE(^PSRX(J,3),"^")

           SET RXF=$PIECE(RX0,"^",9)

           FOR II=0:0

               SET II=$ORDER(^PSRX(J,1,II))

               IF 'II

                   QUIT 

               SET RXF=RXF-1

               IF $PIECE(^PSRX(J,1,II,0),"^",16)

                   SET RST($PIECE(^(0),"^"))=1

 +5        WRITE ?55,$EXTRACT($PIECE(RX0,"^",13),4,5)_"-"_$EXTRACT($PIECE(RX0,"^",13),6,7)_"-"_$EXTRACT($PIECE(RX0,"^",13),2,3)

           IF RXD

               WRITE ?65,$EXTRACT(RXD,4,5)_"-"_$EXTRACT(RXD,6,7)_"-"_$EXTRACT(RXD,2,3)_$SELECT($GET(RST(RXD)):"R",1:"")

           WRITE ?75,"("_RXF_")"

 +6        WRITE !?10,$PIECE(RX0,"^",10)

           KILL RST

           QUIT 

HD         USE IO

           WRITE !!,"RX#     DRUG",?42,"STAT    QTY",?55,"ISSUED ",?65,"LAST FILL REM"

 +1        QUIT