APSPNE4 ; IHS/DSD/ENM - OUTPATIENT LABEL ASK OPTION 11/10/93 ;23-Sep-2011 15:54;PLS
;;7.0;IHS PHARMACY MODIFICATIONS;**1005,1008,1013**;Sep 23, 2004;Build 33
; Modified - IHS/CIA/PLS - 01/21/04
; IHS/MSC/PLS - 04/30/09
; - 09/16/2011 - Added PWH prompt
OUT ;
S:'$D(PPL) PPL=$G(PSORX("PSOL",1))
I $G(PSORX("PSOL",1))]"" S PPL=PSORX("PSOL",1)
OPT ;EP - ASK PRINT OPTION
D CHKFDT^APSPFUNC(.PPL) S PSORX("PSOL",1)=PPL
I 'PPL,'$D(RXRS) D Q
.W !!,"No other labels to print. Exiting..."
N PMI ;IHS/DSD/ENM 05/22/01
S PMI("IN")="" ;IHS/DSD/ENM 05/22/01
S X="APSEPPIM" X ^%ZOSF("TEST") I $T S PMI("IN")=1 ;IHS/DSD/EM 05/22/01
S APSPZ1=$P($G(^APSPCTRL(PSOSITE,0)),"^",12),APSPZ2=$S(APSPZ1=1:"Summary",1:""),APSPZ3=$S(APSPZ1=1:"B=Sum+Cpro",1:"") ;IHS/DSD/ENM 08/01/96
S DIR(0)="SA^P:Print Label;Q:Queue Labels;C:Labels & Chronic Med Profile;R:Refill Rx;M:Med Sheet;MS:Med Sheet+Summary;W:PWH;CA:Cancel Rx" ;_";"_APSPZ2_";"_APSPZ3
I APSPZ2]""!APSPZ3]"" S DIR(0)=DIR(0)_";S:"_APSPZ2_";B:"_APSPZ3
S DIR(0)=DIR(0)_$S($P(PSOPAR,"^",23):";H:Hold",1:"")_$S($P(PSOPAR,"^",24):";SU:Suspense",1:"")
S DIR("A")="Print/Queue/Cpro/Med sheet/pWh/"_$S($P(PSOPAR,U,23):"Hold/",1:"")_$S($P(PSOPAR,U,24):"SUspend/",1:"")_"Refill/CAncel"_"/"_APSPZ2_"/"_APSPZ3_"/'^'=Exit: ",DIR("B")="P" ;IHS/OKCAO/POC 6/9/98
S DIR("?",1)="Enter 'P' to Immediately Print Label(s) only",DIR("?",2)="Enter 'Q' to Queue Label(s) to a Printer",DIR("?",3)="Enter 'C' to Print Label(s) and Chronic Med Profile"
S DIR("?",4)="Enter 'R' to Refill Prescription",DIR("?",5)="Enter 'CA' to Cancel Prescription",DIR("?",6)="*Enter 'S' to Print Labels + Summary Labels"
S DIR("?",7)="*Enter 'B' to Print Label(s) + Chronic Med Profiles + Summary Labels"
S DIR("?",8)="*Note: Summary labels depend on parameter setting in APSP CONTROL FILE"
S DIR("?",9)="ENTER 'M' to print label(s) and patient med sheet" ;IHS/OKCAO/POC 6/9/98
S DIR("?",10)="ENTER 'MS' to print label(s), patient med sheet, and summary label" ;IHS/OKCAO/POC 6/9/98
S DIR("?",11)="Enter 'W' to print a Patient Wellness Handout"
S:$P(PSOPAR,U,23) DIR("?",11)="Enter 'H' to hold label until Rx can be filled"
S:$P(PSOPAR,U,24) DIR("?",12)="Enter 'SU' to suspend labels to print later"
S DIR("?")="ENTER '^' TO EXIT"
W !!
COME D ^DIR S PX=Y,APSPX1=""
I $D(DUOUT) D G CQ:PX=U
.D EXCK
.D:PX=U AL^PSOLBL("UT")
K DIR
OUT1 ;
I $E(PX,1)="R" D G OUT
.W !,*7,"<The Refill Function is currently unavailable!>" Q
.S PSORX("DO REFILL")=1,PX="",APSPZIT=1 D
..I $G(PSORX("DO REFILL")),'PSORX("REFILL") W !,*7,"No prescriptions with refills allowed ",! G OUT ;IHS/DSD/ENM 02/14/97
..I $G(PSORX("DO REFILL")),$D(PSOSD)>1,PSORX("REFILL") W !,"Now entering Refill Option",! N PSOOPT S PSOOPT=4 D ^PSOREF
..K APSPFLG,PSORX("DO REFILL") ;IHS/DSD/ENM 02/14/97
..W !,*7,"<--- RETURNING TO 'NEW RX' OPTION",! Q
I $E(PX,1,2)="CA" D G OUT
.W !,*7,"<The Cancel Function is currently unavailable!>" Q
.D ^APSPCAN W !!
I "P"[PX S APSQSTOP=0 D P^PSORXL K APSQSTOP G CQ ;IHS/OKCAO/POC 01/09/2001 VARIABLE SET FOR SIGNATURE LABEL USED IN APSPLBL AND PSORXL
;IHS/ASD/ENM 05/22/01 NEXT TWO LINES CHECK IF PMI'S EXIST
I "M"[PX,PMI("IN")=1 S APSQSTOP=0 D EN^APSEPPIM,P^PSORXL K APSQSTOP G CQ ;IHS/ASDS/ENM 03/26/01 IHS/OKCAO/POC 01/09/2001 APSQSTOP USED TO DECIDE IF PRINT SIGNATURE LABEL IN RTN APSPLBL AND PSORXL ;IHS/ASDS/ENM 03/26/01
I "M"[PX,PMI("IN")="" S APSQSTOP=0 D P^PSORXL K APSQSTOP G CQ ;IHS/ASDS/ENM 03/26/01 IHS/OKCAO/POC 01/09/2001 APSQSTOP USED TO DECIDE IF PRINT SIGNATURE LABEL IN RTN APSPLBL AND PSORXL ;IHS/ASDS/ENM 03/26/01
I "W"[PX D EN2^APCHPWHG(2,PSODFN),P^PSORXL G CQ ;IHS/MSC/PLS - 09/16/2011
I "C"[PX S APSQSTOP=0 D PCOPY,P^PSORXL,CPCK K APSQSTOP G CQ ;IHS/OKCAO/POC 01/09/2001 APSQSTOP SET FOR PRINTING SIGNATURE LABEL IN RTNS PSORXL AND APSPLBL
I "S"[PX K ARRAY S APSQSTOP=0 D P^PSORXL,EP2^APSPSLBL:$D(ARRAY(1)) K APSQSTOP G CQ ;IHS/DSD/ENM 08/02/96 IHS/OKCAO/POC 01/09/2001 APSQSTOP USED TO PRINT SIGNATURE LABEL IN RTNS APSPLBL AND PSORXL
;IHS/ASD/ENM 05/22/01 NEXT TWO LINES CHECK IF PMI EXIST
I "MS"[PX,PMI("IN")=1 K ARRAY S APSQSTOP=0 D EN^APSEPPIM,P^PSORXL,EP2^APSPSLBL:$D(ARRAY(1)) K APSQSTOP G CQ ;IHS/ASDS/ENM/POC 03/26/2001 APSQSTOP USED TO DECIDE TO PRINT SIGNATURE LABEL IN RTNS APSPLBL AND PSORXL
I "MS"[PX,PMI("IN")="" K ARRAY S APSQSTOP=0 D P^PSORXL,EP2^APSPSLBL:$D(ARRAY(1)) K APSQSTOP G CQ ;IHS/ASDS/ENM 03/26/01 IHS/OKCAO/POC 01/09/2001 APSQSTOP USED TO DECIDE TO PRINT SIGNATURE LABEL IN RTNS APSPLBL AND PSORXL ;IHS/ASDS/ENM 03/26/01
I "B"[PX K ARRAY S APSQSTOP=0 D PCOPY,P^PSORXL,EP2^APSPSLBL:$D(ARRAY(1)),CPCK K APSQSTOP G CQ ;IHS/DSD/ENM 08/02/96 IHS/OKCAO/POC 01/09/2001 APSQSTOP USED TO DECIDE IF PRINT SIGNATURE LABEL IN RTNS APSPLBL AND PSORXL
I "Q"[PX S APSPXQ="1" D Q^PSORXL G CQ ;IHS/DSD/ENM 10/16/97
I PX="H" D H1^PSORXL G CQ ;IHS/CIA/PLS - 01/29/04
I PX="SU" D S^PSORXL G CQ ;IHS/CIA/PLS - 01/29/04
S PX=PX_"^PSORXL" F PI=1:1 Q:$P(PPL,",",PI)="" S DA=$P(PPL,",",PI),ZD=$P(^PSRX(DA,2),"^",2),RXF=0 D @PX
CQ K NEW1,NEW11 D ^%ZISC
U IO(0) K APSEFDT,APSZFDT,ARRAY,SPFL1,AL,PSD,PS(53),PC,PL,PY,PI,PNM,DFN,NOW,PR,IOP,RX,SIG,SIGD,RXM,RX0,RX2,PPL ;S PPL=""
K APFLAG,APSP,APSP1,APSP2,APSPCTR,APSPD,APSPDR,APSPDZ,APSPM0,APSPPDY,APSPPLOT,APSPPMF,APSPRFD,APSPRXX,APSPZDT,APSPZRN,APSPDY,APSPLOT,APSPMF,APSPZ,APSPZ1,APSPZ2,APSPZ3,APSPZZ,APSHRN
K APSPZZN ;IHS/DSD/ENM 07/31/96
Q
PCOPY ;ASK CM COPIES
D COPIES^APSPCP2
Q
CPCK ;CHECK CHRONIC MED PRINT STATUS
I $G(APSPCP)=2 D INIT^APSPCP2 G CQ ;IHS/DSD/ENM 09/05/96
I $G(APSPCPP)]"" S ZTIO=APSPCPP D EMPRT^APSPCP2 G CQ
I APSPCP=1,$G(APSPCPP)']"" D INIT^APSPCP2 G CQ
Q
EXCK ;IHS/DSD/ENM 02/23/96 QUESTION USER EXIT ACTION
;If a user exits before label prints release and label print info
;will not be set.
W !,*7,?30,"Warning!!",!
W ?10,"Exiting at this point will result in an incomplete",!
W ?10,"prescription entry. To avoid future problems with",!
W ?10,"this Rx, PRINT the label and then destroy the label",!
W ?10,"after it prints.",!
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you still want to Exit" D ^DIR K DIR
I Y=0 S PX="P" Q
S PX="^"
Q
APSPNE4 ; IHS/DSD/ENM - OUTPATIENT LABEL ASK OPTION 11/10/93 ;23-Sep-2011 15:54;PLS
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1005,1008,1013**;Sep 23, 2004;Build 33
+2 ; Modified - IHS/CIA/PLS - 01/21/04
+3 ; IHS/MSC/PLS - 04/30/09
+4 ; - 09/16/2011 - Added PWH prompt
OUT ;
+1 IF '$DATA(PPL)
SET PPL=$GET(PSORX("PSOL",1))
+2 IF $GET(PSORX("PSOL",1))]""
SET PPL=PSORX("PSOL",1)
OPT ;EP - ASK PRINT OPTION
+1 DO CHKFDT^APSPFUNC(.PPL)
SET PSORX("PSOL",1)=PPL
+2 IF 'PPL
IF '$DATA(RXRS)
Begin DoDot:1
+3 WRITE !!,"No other labels to print. Exiting..."
End DoDot:1
QUIT
+4 ;IHS/DSD/ENM 05/22/01
NEW PMI
+5 ;IHS/DSD/ENM 05/22/01
SET PMI("IN")=""
+6 ;IHS/DSD/EM 05/22/01
SET X="APSEPPIM"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET PMI("IN")=1
+7 ;IHS/DSD/ENM 08/01/96
SET APSPZ1=$PIECE($GET(^APSPCTRL(PSOSITE,0)),"^",12)
SET APSPZ2=$SELECT(APSPZ1=1:"Summary",1:"")
SET APSPZ3=$SELECT(APSPZ1=1:"B=Sum+Cpro",1:"")
+8 ;_";"_APSPZ2_";"_APSPZ3
SET DIR(0)="SA^P:Print Label;Q:Queue Labels;C:Labels & Chronic Med Profile;R:Refill Rx;M:Med Sheet;MS:Med Sheet+Summary;W:PWH;CA:Cancel Rx"
+9 IF APSPZ2]""!APSPZ3]""
SET DIR(0)=DIR(0)_";S:"_APSPZ2_";B:"_APSPZ3
+10 SET DIR(0)=DIR(0)_$SELECT($PIECE(PSOPAR,"^",23):";H:Hold",1:"")_$SELECT($PIECE(PSOPAR,"^",24):";SU:Suspense",1:"")
+11 ;IHS/OKCAO/POC 6/9/98
SET DIR("A")="Print/Queue/Cpro/Med sheet/pWh/"_$SELECT($PIECE(PSOPAR,U,23):"Hold/",1:"")_$SELECT($PIECE(PSOPAR,U,24):"SUspend/",1:"")_"Refill/CAncel"_"/"_APSPZ2_"/"_APSPZ3_"/'^'=Exit: "
SET DIR("B")="P"
+12 SET DIR("?",1)="Enter 'P' to Immediately Print Label(s) only"
SET DIR("?",2)="Enter 'Q' to Queue Label(s) to a Printer"
SET DIR("?",3)="Enter 'C' to Print Label(s) and Chronic Med Profile"
+13 SET DIR("?",4)="Enter 'R' to Refill Prescription"
SET DIR("?",5)="Enter 'CA' to Cancel Prescription"
SET DIR("?",6)="*Enter 'S' to Print Labels + Summary Labels"
+14 SET DIR("?",7)="*Enter 'B' to Print Label(s) + Chronic Med Profiles + Summary Labels"
+15 SET DIR("?",8)="*Note: Summary labels depend on parameter setting in APSP CONTROL FILE"
+16 ;IHS/OKCAO/POC 6/9/98
SET DIR("?",9)="ENTER 'M' to print label(s) and patient med sheet"
+17 ;IHS/OKCAO/POC 6/9/98
SET DIR("?",10)="ENTER 'MS' to print label(s), patient med sheet, and summary label"
+18 SET DIR("?",11)="Enter 'W' to print a Patient Wellness Handout"
+19 IF $PIECE(PSOPAR,U,23)
SET DIR("?",11)="Enter 'H' to hold label until Rx can be filled"
+20 IF $PIECE(PSOPAR,U,24)
SET DIR("?",12)="Enter 'SU' to suspend labels to print later"
+21 SET DIR("?")="ENTER '^' TO EXIT"
+22 WRITE !!
COME DO ^DIR
SET PX=Y
SET APSPX1=""
+1 IF $DATA(DUOUT)
Begin DoDot:1
+2 DO EXCK
+3 IF PX=U
DO AL^PSOLBL("UT")
End DoDot:1
IF PX=U
GOTO CQ
+4 KILL DIR
OUT1 ;
+1 IF $EXTRACT(PX,1)="R"
Begin DoDot:1
+2 WRITE !,*7,"<The Refill Function is currently unavailable!>"
QUIT
+3 SET PSORX("DO REFILL")=1
SET PX=""
SET APSPZIT=1
Begin DoDot:2
+4 ;IHS/DSD/ENM 02/14/97
IF $GET(PSORX("DO REFILL"))
IF 'PSORX("REFILL")
WRITE !,*7,"No prescriptions with refills allowed ",!
GOTO OUT
+5 IF $GET(PSORX("DO REFILL"))
IF $DATA(PSOSD)>1
IF PSORX("REFILL")
WRITE !,"Now entering Refill Option",!
NEW PSOOPT
SET PSOOPT=4
DO ^PSOREF
+6 ;IHS/DSD/ENM 02/14/97
KILL APSPFLG,PSORX("DO REFILL")
+7 WRITE !,*7,"<--- RETURNING TO 'NEW RX' OPTION",!
QUIT
End DoDot:2
End DoDot:1
GOTO OUT
+8 IF $EXTRACT(PX,1,2)="CA"
Begin DoDot:1
+9 WRITE !,*7,"<The Cancel Function is currently unavailable!>"
QUIT
+10 DO ^APSPCAN
WRITE !!
End DoDot:1
GOTO OUT
+11 ;IHS/OKCAO/POC 01/09/2001 VARIABLE SET FOR SIGNATURE LABEL USED IN APSPLBL AND PSORXL
IF "P"[PX
SET APSQSTOP=0
DO P^PSORXL
KILL APSQSTOP
GOTO CQ
+12 ;IHS/ASD/ENM 05/22/01 NEXT TWO LINES CHECK IF PMI'S EXIST
+13 ;IHS/ASDS/ENM 03/26/01 IHS/OKCAO/POC 01/09/2001 APSQSTOP USED TO DECIDE IF PRINT SIGNATURE LABEL IN RTN APSPLBL AND PSORXL ;IHS/ASDS/ENM 03/26/01
IF "M"[PX
IF PMI("IN")=1
SET APSQSTOP=0
DO EN^APSEPPIM
DO P^PSORXL
KILL APSQSTOP
GOTO CQ
+14 ;IHS/ASDS/ENM 03/26/01 IHS/OKCAO/POC 01/09/2001 APSQSTOP USED TO DECIDE IF PRINT SIGNATURE LABEL IN RTN APSPLBL AND PSORXL ;IHS/ASDS/ENM 03/26/01
IF "M"[PX
IF PMI("IN")=""
SET APSQSTOP=0
DO P^PSORXL
KILL APSQSTOP
GOTO CQ
+15 ;IHS/MSC/PLS - 09/16/2011
IF "W"[PX
DO EN2^APCHPWHG(2,PSODFN)
DO P^PSORXL
GOTO CQ
+16 ;IHS/OKCAO/POC 01/09/2001 APSQSTOP SET FOR PRINTING SIGNATURE LABEL IN RTNS PSORXL AND APSPLBL
IF "C"[PX
SET APSQSTOP=0
DO PCOPY
DO P^PSORXL
DO CPCK
KILL APSQSTOP
GOTO CQ
+17 ;IHS/DSD/ENM 08/02/96 IHS/OKCAO/POC 01/09/2001 APSQSTOP USED TO PRINT SIGNATURE LABEL IN RTNS APSPLBL AND PSORXL
IF "S"[PX
KILL ARRAY
SET APSQSTOP=0
DO P^PSORXL
IF $DATA(ARRAY(1))
DO EP2^APSPSLBL
KILL APSQSTOP
GOTO CQ
+18 ;IHS/ASD/ENM 05/22/01 NEXT TWO LINES CHECK IF PMI EXIST
+19 ;IHS/ASDS/ENM/POC 03/26/2001 APSQSTOP USED TO DECIDE TO PRINT SIGNATURE LABEL IN RTNS APSPLBL AND PSORXL
IF "MS"[PX
IF PMI("IN")=1
KILL ARRAY
SET APSQSTOP=0
DO EN^APSEPPIM
DO P^PSORXL
IF $DATA(ARRAY(1))
DO EP2^APSPSLBL
KILL APSQSTOP
GOTO CQ
+20 ;IHS/ASDS/ENM 03/26/01 IHS/OKCAO/POC 01/09/2001 APSQSTOP USED TO DECIDE TO PRINT SIGNATURE LABEL IN RTNS APSPLBL AND PSORXL ;IHS/ASDS/ENM 03/26/01
IF "MS"[PX
IF PMI("IN")=""
KILL ARRAY
SET APSQSTOP=0
DO P^PSORXL
IF $DATA(ARRAY(1))
DO EP2^APSPSLBL
KILL APSQSTOP
GOTO CQ
+21 ;IHS/DSD/ENM 08/02/96 IHS/OKCAO/POC 01/09/2001 APSQSTOP USED TO DECIDE IF PRINT SIGNATURE LABEL IN RTNS APSPLBL AND PSORXL
IF "B"[PX
KILL ARRAY
SET APSQSTOP=0
DO PCOPY
DO P^PSORXL
IF $DATA(ARRAY(1))
DO EP2^APSPSLBL
DO CPCK
KILL APSQSTOP
GOTO CQ
+22 ;IHS/DSD/ENM 10/16/97
IF "Q"[PX
SET APSPXQ="1"
DO Q^PSORXL
GOTO CQ
+23 ;IHS/CIA/PLS - 01/29/04
IF PX="H"
DO H1^PSORXL
GOTO CQ
+24 ;IHS/CIA/PLS - 01/29/04
IF PX="SU"
DO S^PSORXL
GOTO CQ
+25 SET PX=PX_"^PSORXL"
FOR PI=1:1
IF $PIECE(PPL,",",PI)=""
QUIT
SET DA=$PIECE(PPL,",",PI)
SET ZD=$PIECE(^PSRX(DA,2),"^",2)
SET RXF=0
DO @PX
CQ KILL NEW1,NEW11
DO ^%ZISC
+1 ;S PPL=""
USE IO(0)
KILL APSEFDT,APSZFDT,ARRAY,SPFL1,AL,PSD,PS(53),PC,PL,PY,PI,PNM,DFN,NOW,PR,IOP,RX,SIG,SIGD,RXM,RX0,RX2,PPL
+2 KILL APFLAG,APSP,APSP1,APSP2,APSPCTR,APSPD,APSPDR,APSPDZ,APSPM0,APSPPDY,APSPPLOT,APSPPMF,APSPRFD,APSPRXX,APSPZDT,APSPZRN,APSPDY,APSPLOT,APSPMF,APSPZ,APSPZ1,APSPZ2,APSPZ3,APSPZZ,APSHRN
+3 ;IHS/DSD/ENM 07/31/96
KILL APSPZZN
+4 QUIT
PCOPY ;ASK CM COPIES
+1 DO COPIES^APSPCP2
+2 QUIT
CPCK ;CHECK CHRONIC MED PRINT STATUS
+1 ;IHS/DSD/ENM 09/05/96
IF $GET(APSPCP)=2
DO INIT^APSPCP2
GOTO CQ
+2 IF $GET(APSPCPP)]""
SET ZTIO=APSPCPP
DO EMPRT^APSPCP2
GOTO CQ
+3 IF APSPCP=1
IF $GET(APSPCPP)']""
DO INIT^APSPCP2
GOTO CQ
+4 QUIT
EXCK ;IHS/DSD/ENM 02/23/96 QUESTION USER EXIT ACTION
+1 ;If a user exits before label prints release and label print info
+2 ;will not be set.
+3 WRITE !,*7,?30,"Warning!!",!
+4 WRITE ?10,"Exiting at this point will result in an incomplete",!
+5 WRITE ?10,"prescription entry. To avoid future problems with",!
+6 WRITE ?10,"this Rx, PRINT the label and then destroy the label",!
+7 WRITE ?10,"after it prints.",!
+8 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Do you still want to Exit"
DO ^DIR
KILL DIR
+9 IF Y=0
SET PX="P"
QUIT
+10 SET PX="^"
+11 QUIT
