APSPDSC ; IHS/DSD/ENM - PRINT DISCHARGE SHEET ;29-Jan-2004 08:56;PLS
;;7.0;IHS PHARMACY MODIFICATIONS;;09/03/97
; Modified - IHS/CIA/PLS - 01/14/04
D INIT
START D PAT G END:APSPDSC("FLG")
D ^PSOBUILD
S APSPDSC("ST")="ACTIVE" D ^PSODSPL
I $G(PSOSD)']"" S APSPDSC("FLG")=1 G END ;IHS/DSD/ENM 08/14/96
D ASK G APSPDSC:APSPDSC("FLG")=2
;IHS/ITSC/ENM 01/24/03 NEXT 2 LINES COPIED/MOD
D COPIES I APSPDSC("FLG")=4 D EOJ G APSPDSC ;IHS/DSD/ENM/POC 08/10/02
D DEVICE I APSPDSC("FLG")=3 D EOJ G APSPDSC ;IHS/DSD/ENM/POC 08/10/02
D ^APSPDSC1
END D EOJ
Q
;-----------------------------------------------
INIT ;
S APSPDSC("FLG")=0
S X1=DT,X2=-45 D C^%DTC S PSEED=X-1 K X,X1,X2
K PSOSD,PSODFN S PSFROM="N",(PSOSD,APSPDSC("FLG"))=0
S PSOOPT=1
S APSPAGE=1
S Y=DT X ^DD("DD") S APSPDSC("DATE")=Y
I $D(DUZ(2)),$D(^DIC(4,DUZ(2),0)),$P(^(0),U,1)]"" S APSPDSC("FAC")=$P(^(0),U,1)
Q
PAT ;
S DIC="^AUPNPAT(",DIC(0)="QEAM" D ^DIC K DIC,DR
I "^"[X!'$T S APSPDSC("FLG")=1 G PATX
G PAT:+Y<0
I '$D(^PS(55,+Y,"P")) W !?20,"NO PHARMACY INFORMATION" G PAT
S PSODFN=+Y
S:$D(^DPT(PSODFN,0))#2 APSPDSC("NAME")=$P(^(0),U,1)
PATX ;
Q
ASK ;
K X,DIR
S DIR("A")="CHOOSE FROM ",DIR("?")="^D QUES^APSPDSC",DIR(0)="L^1:"_$G(APSPZDT) D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIRUT) S APSPDSC("FLG")=2 G ASKX
S PSRXS=Y
I "^"[PSRXS S APSPDSC("FLG")=2 G ASKX
I PSRXS["-" D QUES,^PSODSPL G ASK ;IHS/DSD/ENM 6.29.95
I PSRXS'?1N.E!(+PSRXS>PSOSD) D QUES D ^PSODSPL G ASK
;IHS/DSD/ENM 6/09/97 $ NEXT REMOVED FM NEXT LINE 'APS3 ADDED
;F APS=1:1 S APS1=$P(PSRXS,",",APS) Q:APS1="" S APS3="" F APS2=1:1:APS1 S APS3=$O(PSOSD(APS3)) Q:APS3="" I APS2=APS1 W !,APS3 S APSX=$S($D(APSX):APSX_","_$P(+PSOSD(APS3),U,1),1:$P(+PSOSD(APS3),U,1))
; Restrict display to ACTIVE scripts
; v7.0 PSOBUILD returns array with 2 subscripts (1st=status, 2nd=drug name)
F APS=1:1 S APS1=$P(PSRXS,",",APS) Q:APS1="" D
.S APS3="" F APS2=1:1:APS1 D
..S APS3=$O(PSOSD("ACTIVE",APS3)) Q:APS3="" D
...I APS2=APS1 D
....W !,APS3 S APSX=$S($D(APSX):APSX_","_$P(+PSOSD("ACTIVE",APS3),U,1),1:$P(+PSOSD("ACTIVE",APS3),U,1))
ASKX ;Exit for ASK subroutine
K APS,APS1,APS2,APS3
Q
QUES ;
W !?5,"Enter the item #(s) or RX #(s) you wish to print seperated by commas or dash."
W !?5,"For example: 1,2,5 or 1-5 or 123456,33254A,232323B."
W !?5,"Do not enter the same number twice, duplicates are not allowed."
Q
DEVICE ;
S %ZIS="QM"
S %ZIS("A")="Please enter PATIENT INSTRUCTION SHEET device: " D ^%ZIS
I POP K POP S APSPDSC("FLG")=3 G DEVICEX
I $D(IO("Q")),IO=IO(0) W !!,"Sorry, you cannot queue to your screen or to a slave printer.",! K IO("Q") G DEVICE
G DEVICEX:'$D(IO("Q"))
K ZTSAVE
F APSF="APSPAGE","APSX","APSPDSC(""NAME"")","APSPDSC(""DATE"")","APSPDSC(""FAC"")","APSPDSC(""COPIES"")","IOM","PSODFN" S ZTSAVE(APSF)=""
S ZTRTN="^APSPDSC1",ZTIO=ION
S ZTDESC="MEDICATION INSTRUCTIONS"
D ^%ZTLOAD
S APSPDSC("FLG")=3
DEVICEX ;
Q
COPIES ;
S DIR(0)="NO^1:10:0"
S DIR("B")=1,DIR("A")="Number of copies:"
D ^DIR
I $D(DIRUT)!($D(DTOUT)) S APSPDSC("FLG")=4 G COPIESX
S APSPDSC("COPIES")=$S(+Y>0:+Y,1:1)
COPIESX ;
K DIR
Q
EOJ ;EP
K %ZIS,APS,APS1,APS2,APS3,APSPDSC,APSF,APSPAGE,APSX,DIC,PSOSD,PSODFN,PSEED
K PSFROM,PSOSD,PSRXS,X,X1,X2,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,POP,IO("Q")
K DRG,DRX0,PS,PSC,PSISD,PSLC,REFRM,RX0,RX2,RX3,ST,ST0,STAR,Z0,Z1,W
K DIR,DIRUT,DTOUT
Q
APSPDSC ; IHS/DSD/ENM - PRINT DISCHARGE SHEET ;29-Jan-2004 08:56;PLS
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;;09/03/97
+2 ; Modified - IHS/CIA/PLS - 01/14/04
+3 DO INIT
START DO PAT
IF APSPDSC("FLG")
GOTO END
+1 DO ^PSOBUILD
+2 SET APSPDSC("ST")="ACTIVE"
DO ^PSODSPL
+3 ;IHS/DSD/ENM 08/14/96
IF $GET(PSOSD)']""
SET APSPDSC("FLG")=1
GOTO END
+4 DO ASK
IF APSPDSC("FLG")=2
GOTO APSPDSC
+5 ;IHS/ITSC/ENM 01/24/03 NEXT 2 LINES COPIED/MOD
+6 ;IHS/DSD/ENM/POC 08/10/02
DO COPIES
IF APSPDSC("FLG")=4
DO EOJ
GOTO APSPDSC
+7 ;IHS/DSD/ENM/POC 08/10/02
DO DEVICE
IF APSPDSC("FLG")=3
DO EOJ
GOTO APSPDSC
+8 DO ^APSPDSC1
END DO EOJ
+1 QUIT
+2 ;-----------------------------------------------
INIT ;
+1 SET APSPDSC("FLG")=0
+2 SET X1=DT
SET X2=-45
DO C^%DTC
SET PSEED=X-1
KILL X,X1,X2
+3 KILL PSOSD,PSODFN
SET PSFROM="N"
SET (PSOSD,APSPDSC("FLG"))=0
+4 SET PSOOPT=1
+5 SET APSPAGE=1
+6 SET Y=DT
XECUTE ^DD("DD")
SET APSPDSC("DATE")=Y
+7 IF $DATA(DUZ(2))
IF $DATA(^DIC(4,DUZ(2),0))
IF $PIECE(^(0),U,1)]""
SET APSPDSC("FAC")=$PIECE(^(0),U,1)
+8 QUIT
PAT ;
+1 SET DIC="^AUPNPAT("
SET DIC(0)="QEAM"
DO ^DIC
KILL DIC,DR
+2 IF "^"[X!'$TEST
SET APSPDSC("FLG")=1
GOTO PATX
+3 IF +Y<0
GOTO PAT
+4 IF '$DATA(^PS(55,+Y,"P"))
WRITE !?20,"NO PHARMACY INFORMATION"
GOTO PAT
+5 SET PSODFN=+Y
+6 IF $DATA(^DPT(PSODFN,0))#2
SET APSPDSC("NAME")=$PIECE(^(0),U,1)
PATX ;
+1 QUIT
ASK ;
+1 KILL X,DIR
+2 SET DIR("A")="CHOOSE FROM "
SET DIR("?")="^D QUES^APSPDSC"
SET DIR(0)="L^1:"_$GET(APSPZDT)
DO ^DIR
KILL DIR
+3 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)
SET APSPDSC("FLG")=2
GOTO ASKX
+4 SET PSRXS=Y
+5 IF "^"[PSRXS
SET APSPDSC("FLG")=2
GOTO ASKX
+6 ;IHS/DSD/ENM 6.29.95
IF PSRXS["-"
DO QUES
DO ^PSODSPL
GOTO ASK
+7 IF PSRXS'?1N.E!(+PSRXS>PSOSD)
DO QUES
DO ^PSODSPL
GOTO ASK
+8 ;IHS/DSD/ENM 6/09/97 $ NEXT REMOVED FM NEXT LINE 'APS3 ADDED
+9 ;F APS=1:1 S APS1=$P(PSRXS,",",APS) Q:APS1="" S APS3="" F APS2=1:1:APS1 S APS3=$O(PSOSD(APS3)) Q:APS3="" I APS2=APS1 W !,APS3 S APSX=$S($D(APSX):APSX_","_$P(+PSOSD(APS3),U,1),1:$P(+PSOSD(APS3),U,1))
+10 ; Restrict display to ACTIVE scripts
+11 ; v7.0 PSOBUILD returns array with 2 subscripts (1st=status, 2nd=drug name)
+12 FOR APS=1:1
SET APS1=$PIECE(PSRXS,",",APS)
IF APS1=""
QUIT
Begin DoDot:1
+13 SET APS3=""
FOR APS2=1:1:APS1
Begin DoDot:2
+14 SET APS3=$ORDER(PSOSD("ACTIVE",APS3))
IF APS3=""
QUIT
Begin DoDot:3
+15 IF APS2=APS1
Begin DoDot:4
+16 WRITE !,APS3
SET APSX=$SELECT($DATA(APSX):APSX_","_$PIECE(+PSOSD("ACTIVE",APS3),U,1),1:$PIECE(+PSOSD("ACTIVE",APS3),U,1))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
ASKX ;Exit for ASK subroutine
+1 KILL APS,APS1,APS2,APS3
+2 QUIT
QUES ;
+1 WRITE !?5,"Enter the item #(s) or RX #(s) you wish to print seperated by commas or dash."
+2 WRITE !?5,"For example: 1,2,5 or 1-5 or 123456,33254A,232323B."
+3 WRITE !?5,"Do not enter the same number twice, duplicates are not allowed."
+4 QUIT
DEVICE ;
+1 SET %ZIS="QM"
+2 SET %ZIS("A")="Please enter PATIENT INSTRUCTION SHEET device: "
DO ^%ZIS
+3 IF POP
KILL POP
SET APSPDSC("FLG")=3
GOTO DEVICEX
+4 IF $DATA(IO("Q"))
IF IO=IO(0)
WRITE !!,"Sorry, you cannot queue to your screen or to a slave printer.",!
KILL IO("Q")
GOTO DEVICE
+5 IF '$DATA(IO("Q"))
GOTO DEVICEX
+6 KILL ZTSAVE
+7 FOR APSF="APSPAGE","APSX","APSPDSC(""NAME"")","APSPDSC(""DATE"")","APSPDSC(""FAC"")","APSPDSC(""COPIES"")","IOM","PSODFN"
SET ZTSAVE(APSF)=""
+8 SET ZTRTN="^APSPDSC1"
SET ZTIO=ION
+9 SET ZTDESC="MEDICATION INSTRUCTIONS"
+10 DO ^%ZTLOAD
+11 SET APSPDSC("FLG")=3
DEVICEX ;
+1 QUIT
COPIES ;
+1 SET DIR(0)="NO^1:10:0"
+2 SET DIR("B")=1
SET DIR("A")="Number of copies:"
+3 DO ^DIR
+4 IF $DATA(DIRUT)!($DATA(DTOUT))
SET APSPDSC("FLG")=4
GOTO COPIESX
+5 SET APSPDSC("COPIES")=$SELECT(+Y>0:+Y,1:1)
COPIESX ;
+1 KILL DIR
+2 QUIT
EOJ ;EP
+1 KILL %ZIS,APS,APS1,APS2,APS3,APSPDSC,APSF,APSPAGE,APSX,DIC,PSOSD,PSODFN,PSEED
+2 KILL PSFROM,PSOSD,PSRXS,X,X1,X2,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,POP,IO("Q")
+3 KILL DRG,DRX0,PS,PSC,PSISD,PSLC,REFRM,RX0,RX2,RX3,ST,ST0,STAR,Z0,Z1,W
+4 KILL DIR,DIRUT,DTOUT
+5 QUIT
