- 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
