APSPDSC1 ; IHS/DSD/ENM - PRINT MEDICATION DISCHARGE FORM ;29-Jan-2004 08:56;PLS
;;7.0;IHS PHARMACY MODIFICATIONS;;09/03/97
; IHS/OHPRD/JCM 8/22/90 INSERT K APSS AT HEADER+7, MADE W CONDITIONAL
; ON LINE START+6
; Modified - IHS/CIA/PLS - 01/13/04
U IO
F I=1:1:APSPDSC("COPIES") D START Q:APSPDSC("COPIES")<1 ;COPY LOOP
D ^%ZISC
D EOJ
Q
START ;
S (DX,DY)=1 X:$D(^%ZOSF("XY"))#2 ^("XY")
S APSPAGE=1
D HEADER
D MEDS
D:$E(IOST,1,2)="P-" TRAILER
W:$E(IOST,1,2)="P-" !,@IOF ;IHS/OHPRD/JCM 8/22/90
S APSPDSC("COPIES")=APSPDSC("COPIES")-1
Q
;-------------------------------------------------------------------
W:$D(APSPDSC("NAME")) !,"Name : ",APSPDSC("NAME")
W ?(IOM-20),"Date : ",APSPDSC("DATE")
W !?(IOM-20),"Page: ",APSPAGE
I APSPAGE'>1 D EP^APSPGMR ;IHS/DSD/ENM 09/05/96
W !
W:$D(APSPDSC("FAC")) ?(IOM\2-($L(APSPDSC("FAC"))\2)),APSPDSC("FAC")
W !?(IOM\2-12),"MEDICATION INSTRUCTIONS",!
K APSS S $P(APSS,"-",(IOM-2))="" W APSS ;IHS/OHPRD/JCM 8/22/90
S APSPAGE=APSPAGE+1
Q
MEDS ;
S APSCNT=1,APSRX=0
F S APSRX=$P(APSX,",",APSCNT) Q:APSRX="" S APSCNT=APSCNT+1 D RX
Q
RX ;
Q:'$D(^PSRX(APSRX,0))#2 S APSRX0=^(0)
I $P(APSRX0,U,6),$D(^PSDRUG($P(APSRX0,U,6),0))#2 S APSDRUG=^(0)
S APSSIG=$P($G(^PSRX(APSRX,"SIG")),"^")
I APSSIG="" S APSSIG=$P($G(^PSRX(APSRX,"SIG1",1,0)),"^")
Q:APSSIG="" ;IHS/BAO/DMH dmh 3/26/2002
Q:'$D(APSDRUG)!('$D(APSSIG))
S APSDNAME=$P(APSDRUG,U,1) ; Drug name
D SIG,WARNING
Q
SIG ;
N INS1 ; IHS/CIA/PLS 01/12/04
S X=APSSIG D SIG^PSOHELP
I $Y+($L(INS1)\(IOM-30))+1>IOSL,$E(IOST,1,2)="P-" W !,@IOF D HEADER
I IO=IO(0),$E(IOST,1,2)'="P-",$Y+2>IOSL S APSPDSC1("QUIT FLG")=0 S DIR(0)="E" D ^DIR S:Y="^" APSPDSC1("QUIT FLG")=1 K DIR,Y W @IOF G:APSPDSC1("QUIT FLG") SIGX
W !,APSS
W !!!,APSDNAME," - "
W ?30,$E(INS1,1,(IOM-1))
I $E(INS1,(IOM-1))]" " W "-"
S APS2P=(IOM-1)
I $Y+4>IOSL,$E(IOST,1,2)="P-" W !,@IOF D HEADER
I IO=IO(0),$E(IOST,1,2)'="P-",$Y+2>IOSL S APSPDSC1("QUIT FLG")=0 S DIR(0)="E" D ^DIR S:Y=0 APSPDSC1("QUIT FLG")=1 K DIR,Y W @IOF G:APSPDSC1("QUIT FLG") SIGX
I $L(INS1)>(IOM-1) F W !?30,$E(INS1,APS2P+1,(APS2P+(IOM-32))) Q:$L(INS1)'>(APS2P+(IOM-32)) W:$E(INS1,(APS2P+(IOM-31)))]" " "-" S APS2P=APS2P+(IOM-32)
SIGX ;
Q
WARNING ;
Q:$P(APSDRUG,U,8)']""
S APSWLS=$P(APSDRUG,U,8)
S APSCNT2=1,APSWL=0
F S APSWL=$P(APSWLS,",",APSCNT2) Q:APSWL="" S APSCNT2=APSCNT2+1 D WARN2
Q
WARN3 ;IHS/DSD/ENM 06/10/97 ENM MODIFIED WARN2 MODULE
S APSPJ=0,APSPK=""
F S APSPJ=$O(^DIC(54,APSWL,1,APSPJ)) Q:APSPJ'=+APSPJ S APSPK=^DIC(54,APSWL,1,APSPJ,0) D EMW
Q
EMW I $Y+($L(APSPK)\(IOM-1))+1>IOSL,$E(IOST,1,2)="P-" W !,@IOF D HEADER
I IO=IO(0),$E(IOST,1,2)'="P-",$Y+2>IOSL S APSPDSC1("QUIT FLG")=0 S DIR(0)="E" D ^DIR S:Y="^" APSPDSC1("QUIT FLG")=1 K DIR,Y W @IOF G:APSPDSC1("QUIT FLG") WARN2X
W !!?2,$E(APSPK,1,(IOM-1))
I $E(APSPK,(IOM-1))]" " W "-"
S APS2P=(IOM-1)
I $L(APSPK)>APS2P F W !,$E(APSPK,APS2P+1,(APS2P+(IOM-1))) Q:$L(APSPK)'>(APS2P+(IOM-1)) W:'" "[$E(APSPK,(APS2P+(IOM-1))) "-" S APS2P=APS2P+(IOM-1)
WARN3X ;IHS/DSD/ENM END OF ENM WARN2 MODULE
Q
WARN2 ;IHS/DSD/ENM V5.06 WARN2 MODULE
S APSPJ=0,APSPK=""
F S APSPJ=$O(^DIC(54,APSWL,1,APSPJ)) Q:APSPJ'=+APSPJ S APSPK=$S(APSPK'="":APSPK_" "_^DIC(54,APSWL,1,APSPJ,0),1:^DIC(54,APSWL,1,APSPJ,0))
I $Y+($L(APSPK)\(IOM-10))+1>IOSL,$E(IOST,1,2)="P-" W !,@IOF D HEADER
I IO=IO(0),$E(IOST,1,2)'="P-",$Y+2>IOSL S APSPDSC1("QUIT FLG")=0 S DIR(0)="E" D ^DIR S:Y="^" APSPDSC1("QUIT FLG")=1 K DIR,Y W @IOF G:APSPDSC1("QUIT FLG") WARN2X
W !!?10,$E(APSPK,1,(IOM-12))
I $E(APSPK,(IOM-11))]" " W "-"
S APS2P=(IOM-12)
I $L(APSPK)>APS2P F W !?10,$E(APSPK,APS2P+1,(APS2P+(IOM-12))) Q:$L(APSPK)'>(APS2P+(IOM-12)) W:'" "[$E(APSPK,(APS2P+(IOM-11))) "-" S APS2P=APS2P+(IOM-12)
WARN2X ;
Q
TRAILER ;
I $Y+17>IOSL W !,@IOF D HEADER
W !,APSS
W !!!,"ADDITIONAL COMMENTS:",!
F APSI=1:1:3 W !!,APSS
W !!?(IOM-28) S APSS="",$P(APSS,"_",25)="" W APSS
W !?(IOM-20),"PHARMACIST"
Q
EOJ ;
K APS2P,APSCNT,APSCNT2,APSPDSC,APSDNAME,APSDRUG,APSI,APSPAGE,APSRX,APSPDSC1("QUIT FLG")
K APSRX0,APSS,APSSIG,APSWL,APSWLS,APSX,APSPJ,APSPK,SIG,X,DX,DY,I
I $D(ZTSK) K ZTSAVE,ZTIO,ZTDESC,ZTRTN,ZTSK ;IHS/DSD/ENM 01/14/97
D EOJ^APSPDSC ;IHS/ITSC/POC/ENM 08/08/2002
Q
APSPDSC1 ; IHS/DSD/ENM - PRINT MEDICATION DISCHARGE FORM ;29-Jan-2004 08:56;PLS
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;;09/03/97
+2 ; IHS/OHPRD/JCM 8/22/90 INSERT K APSS AT HEADER+7, MADE W CONDITIONAL
+3 ; ON LINE START+6
+4 ; Modified - IHS/CIA/PLS - 01/13/04
+5 USE IO
+6 ;COPY LOOP
FOR I=1:1:APSPDSC("COPIES")
DO START
IF APSPDSC("COPIES")<1
QUIT
+7 DO ^%ZISC
+8 DO EOJ
+9 QUIT
START ;
+1 SET (DX,DY)=1
IF $DATA(^%ZOSF("XY"))#2
XECUTE ^("XY")
+2 SET APSPAGE=1
+3 DO HEADER
+4 DO MEDS
+5 IF $EXTRACT(IOST,1,2)="P-"
DO TRAILER
+6 ;IHS/OHPRD/JCM 8/22/90
IF $EXTRACT(IOST,1,2)="P-"
WRITE !,@IOF
+7 SET APSPDSC("COPIES")=APSPDSC("COPIES")-1
+8 QUIT
+9 ;-------------------------------------------------------------------
+1 IF $DATA(APSPDSC("NAME"))
WRITE !,"Name : ",APSPDSC("NAME")
+2 WRITE ?(IOM-20),"Date : ",APSPDSC("DATE")
+3 WRITE !?(IOM-20),"Page: ",APSPAGE
+4 ;IHS/DSD/ENM 09/05/96
IF APSPAGE'>1
DO EP^APSPGMR
+5 WRITE !
+6 IF $DATA(APSPDSC("FAC"))
WRITE ?(IOM\2-($LENGTH(APSPDSC("FAC"))\2)),APSPDSC("FAC")
+7 WRITE !?(IOM\2-12),"MEDICATION INSTRUCTIONS",!
+8 ;IHS/OHPRD/JCM 8/22/90
KILL APSS
SET $PIECE(APSS,"-",(IOM-2))=""
WRITE APSS
+9 SET APSPAGE=APSPAGE+1
+10 QUIT
MEDS ;
+1 SET APSCNT=1
SET APSRX=0
+2 FOR
SET APSRX=$PIECE(APSX,",",APSCNT)
IF APSRX=""
QUIT
SET APSCNT=APSCNT+1
DO RX
+3 QUIT
RX ;
+1 IF '$DATA(^PSRX(APSRX,0))#2
QUIT
SET APSRX0=^(0)
+2 IF $PIECE(APSRX0,U,6)
IF $DATA(^PSDRUG($PIECE(APSRX0,U,6),0))#2
SET APSDRUG=^(0)
+3 SET APSSIG=$PIECE($GET(^PSRX(APSRX,"SIG")),"^")
+4 IF APSSIG=""
SET APSSIG=$PIECE($GET(^PSRX(APSRX,"SIG1",1,0)),"^")
+5 ;IHS/BAO/DMH dmh 3/26/2002
IF APSSIG=""
QUIT
+6 IF '$DATA(APSDRUG)!('$DATA(APSSIG))
QUIT
+7 ; Drug name
SET APSDNAME=$PIECE(APSDRUG,U,1)
+8 DO SIG
DO WARNING
+9 QUIT
SIG ;
+1 ; IHS/CIA/PLS 01/12/04
NEW INS1
+2 SET X=APSSIG
DO SIG^PSOHELP
+3 IF $Y+($LENGTH(INS1)\(IOM-30))+1>IOSL
IF $EXTRACT(IOST,1,2)="P-"
WRITE !,@IOF
DO HEADER
+4 IF IO=IO(0)
IF $EXTRACT(IOST,1,2)'="P-"
IF $Y+2>IOSL
SET APSPDSC1("QUIT FLG")=0
SET DIR(0)="E"
DO ^DIR
IF Y="^"
SET APSPDSC1("QUIT FLG")=1
KILL DIR,Y
WRITE @IOF
IF APSPDSC1("QUIT FLG")
GOTO SIGX
+5 WRITE !,APSS
+6 WRITE !!!,APSDNAME," - "
+7 WRITE ?30,$EXTRACT(INS1,1,(IOM-1))
+8 IF $EXTRACT(INS1,(IOM-1))]" "
WRITE "-"
+9 SET APS2P=(IOM-1)
+10 IF $Y+4>IOSL
IF $EXTRACT(IOST,1,2)="P-"
WRITE !,@IOF
DO HEADER
+11 IF IO=IO(0)
IF $EXTRACT(IOST,1,2)'="P-"
IF $Y+2>IOSL
SET APSPDSC1("QUIT FLG")=0
SET DIR(0)="E"
DO ^DIR
IF Y=0
SET APSPDSC1("QUIT FLG")=1
KILL DIR,Y
WRITE @IOF
IF APSPDSC1("QUIT FLG")
GOTO SIGX
+12 IF $LENGTH(INS1)>(IOM-1)
FOR
WRITE !?30,$EXTRACT(INS1,APS2P+1,(APS2P+(IOM-32)))
IF $LENGTH(INS1)'>(APS2P+(IOM-32))
QUIT
IF $EXTRACT(INS1,(APS2P+(IOM-31)))]" "
WRITE "-"
SET APS2P=APS2P+(IOM-32)
SIGX ;
+1 QUIT
WARNING ;
+1 IF $PIECE(APSDRUG,U,8)']""
QUIT
+2 SET APSWLS=$PIECE(APSDRUG,U,8)
+3 SET APSCNT2=1
SET APSWL=0
+4 FOR
SET APSWL=$PIECE(APSWLS,",",APSCNT2)
IF APSWL=""
QUIT
SET APSCNT2=APSCNT2+1
DO WARN2
+5 QUIT
WARN3 ;IHS/DSD/ENM 06/10/97 ENM MODIFIED WARN2 MODULE
+1 SET APSPJ=0
SET APSPK=""
+2 FOR
SET APSPJ=$ORDER(^DIC(54,APSWL,1,APSPJ))
IF APSPJ'=+APSPJ
QUIT
SET APSPK=^DIC(54,APSWL,1,APSPJ,0)
DO EMW
+3 QUIT
EMW IF $Y+($LENGTH(APSPK)\(IOM-1))+1>IOSL
IF $EXTRACT(IOST,1,2)="P-"
WRITE !,@IOF
DO HEADER
+1 IF IO=IO(0)
IF $EXTRACT(IOST,1,2)'="P-"
IF $Y+2>IOSL
SET APSPDSC1("QUIT FLG")=0
SET DIR(0)="E"
DO ^DIR
IF Y="^"
SET APSPDSC1("QUIT FLG")=1
KILL DIR,Y
WRITE @IOF
IF APSPDSC1("QUIT FLG")
GOTO WARN2X
+2 WRITE !!?2,$EXTRACT(APSPK,1,(IOM-1))
+3 IF $EXTRACT(APSPK,(IOM-1))]" "
WRITE "-"
+4 SET APS2P=(IOM-1)
+5 IF $LENGTH(APSPK)>APS2P
FOR
WRITE !,$EXTRACT(APSPK,APS2P+1,(APS2P+(IOM-1)))
IF $LENGTH(APSPK)'>(APS2P+(IOM-1))
QUIT
IF '" "[$EXTRACT(APSPK,(APS2P+(IOM-1)))
WRITE "-"
SET APS2P=APS2P+(IOM-1)
WARN3X ;IHS/DSD/ENM END OF ENM WARN2 MODULE
+1 QUIT
WARN2 ;IHS/DSD/ENM V5.06 WARN2 MODULE
+1 SET APSPJ=0
SET APSPK=""
+2 FOR
SET APSPJ=$ORDER(^DIC(54,APSWL,1,APSPJ))
IF APSPJ'=+APSPJ
QUIT
SET APSPK=$SELECT(APSPK'="":APSPK_" "_^DIC(54,APSWL,1,APSPJ,0),1:^DIC(54,APSWL,1,APSPJ,0))
+3 IF $Y+($LENGTH(APSPK)\(IOM-10))+1>IOSL
IF $EXTRACT(IOST,1,2)="P-"
WRITE !,@IOF
DO HEADER
+4 IF IO=IO(0)
IF $EXTRACT(IOST,1,2)'="P-"
IF $Y+2>IOSL
SET APSPDSC1("QUIT FLG")=0
SET DIR(0)="E"
DO ^DIR
IF Y="^"
SET APSPDSC1("QUIT FLG")=1
KILL DIR,Y
WRITE @IOF
IF APSPDSC1("QUIT FLG")
GOTO WARN2X
+5 WRITE !!?10,$EXTRACT(APSPK,1,(IOM-12))
+6 IF $EXTRACT(APSPK,(IOM-11))]" "
WRITE "-"
+7 SET APS2P=(IOM-12)
+8 IF $LENGTH(APSPK)>APS2P
FOR
WRITE !?10,$EXTRACT(APSPK,APS2P+1,(APS2P+(IOM-12)))
IF $LENGTH(APSPK)'>(APS2P+(IOM-12))
QUIT
IF '" "[$EXTRACT(APSPK,(APS2P+(IOM-11)))
WRITE "-"
SET APS2P=APS2P+(IOM-12)
WARN2X ;
+1 QUIT
TRAILER ;
+1 IF $Y+17>IOSL
WRITE !,@IOF
DO HEADER
+2 WRITE !,APSS
+3 WRITE !!!,"ADDITIONAL COMMENTS:",!
+4 FOR APSI=1:1:3
WRITE !!,APSS
+5 WRITE !!?(IOM-28)
SET APSS=""
SET $PIECE(APSS,"_",25)=""
WRITE APSS
+6 WRITE !?(IOM-20),"PHARMACIST"
+7 QUIT
EOJ ;
+1 KILL APS2P,APSCNT,APSCNT2,APSPDSC,APSDNAME,APSDRUG,APSI,APSPAGE,APSRX,APSPDSC1("QUIT FLG")
+2 KILL APSRX0,APSS,APSSIG,APSWL,APSWLS,APSX,APSPJ,APSPK,SIG,X,DX,DY,I
+3 ;IHS/DSD/ENM 01/14/97
IF $DATA(ZTSK)
KILL ZTSAVE,ZTIO,ZTDESC,ZTRTN,ZTSK
+4 ;IHS/ITSC/POC/ENM 08/08/2002
DO EOJ^APSPDSC
+5 QUIT
