APSQSIGN ;IHS/OKCAO/POC - RTN PRINTS SIGNATURE LABEL;19-Jan-2011 08:35;SM
;;7.0;IHS PHARMACY MODIFICATIONS;**1003,1004,1005,1006,1007,1009,1010**;Sep 23, 2004
;ROUTINE TO WRITE SIGNATURE INFORMATION ON RX LABEL
; Modified - IHS/CIA/PLS - 01/13/04
; 03/21/05
; 10/26/05 - Line ENL+2
; IHS/MSC/PLS 03/01/06 - Line ZIS+11, added EN2+2
; 08/08/06 - Added line EN2+3
; 08/19/08 - Line EPAGN+4
; 04/30/10 - Line ENLT+5
; 01/19/11 - Line HDR+10
ENL(PPL,QUIT,SKIP,WHICH,PRT,SITE,NOQ) ; EP for use when site is printing on laser labels
N PTYPE,ZTRTN,ZTIO,ZTDESC,ZTREQ,ZTSAVE
N VAR,ZTSK ; IHS/CIA/PLS - 10/26/05 - Added ZTSK variable
S PRT=$P($G(PRT),U),PTYPE=$P($G(PRT),U,2)
Q:'$L($G(PRT)) ; Requires a device
S NOQ=$G(NOQ,0) ; Set default for No-queue
I NOQ,PRT=$G(PSOLAP) D
.D ENLT
E D
.S ZTRTN="ENLT^APSQSIGN"
.S ZTDESC="Signature Label Print"
.S ZTDTH=$H
.S ZTIO=PRT
.F VAR="SITE","PPL","QUIT","SKIP","WHICH" S:$D(@VAR) ZTSAVE(VAR)=""
.D ^%ZTLOAD
Q
ENLT ; Tasked entry point
S ZTREQ="@"
N LP,RX,RX0,DFN,RXN,TMP,PSOFROM
N LASTPCE,THISPCE,I,J,K,L,LINE,NAME,NAMDAT,LINEBEG,LINEEND
N LINEMAX,LINESP,LINELEN,RX,RXSTNG,X,NUM,D,SITEPAR,RXN,RXSTING
N DATE,DOB
F LP=1:1 S RX=$P(PPL,",",LP) Q:RX="" D
.; Build patient/script number array
.S RX0=$G(^PSRX(RX,0))
.S DFN=$P(RX0,U,2),RXN=$P(RX0,U)
.I DFN,$L(RXN) S TMP(DFN,RXN)=""
Q:'$D(TMP)
; Build array for printing
S DFN=0 F S DFN=$O(TMP(DFN)) Q:'DFN D
.N APSQSTG,LP,RXN
.S RXN="" F LP=1:1 S RXN=$O(TMP(DFN,RXN)) Q:RXN="" D
..S APSQSTG(LP)=DFN_U_RXN
.D PARMSET(SITE)
.D BEGIN
Q
EN(APSQSTG,QUIT,SKIP,WHICH) ;EP
;QUIT IS TO DECIDE IF WANT TO EXECUTE THIS RTN AT ALL
;SKIP IS PARAMETER TO DECIDE IF PRINT EXTRA BLANK LABELS
;LINESKIP IS THE NUMBER OF LABELS TO SKIP
;APSQSTG IS THE STRING OF RX NUMBERS TO WRITE
;SITEPAR IS THE PARAMETER TO DECIDE IF WRITE
;LINEBEG IS THE NUMBER OF LINES TO SKIP AT BEGINNING OF LABEL
;LINEEND IS THE NUMBER OF LINES TO SKIP AT END OF LABEL
;LINEMAX IS THE NUMBER OF LINES IN THE LABEL
;LINESP IS THE NUMBER OF SPACES TO START AT ON EACH LINE
;LINELEN IS THE MAX LENGTH OF A LINE
;LINE IS THE NUMBER OF LINES USED
;SITEPAR IS PARAMETER TO DECIDE UNDER WHAT CONDITIONS THIS RTN PRINTS FOUND IN APSP CONTROL FILE
N LASTPCE,THISPCE,I,J,K,L,LINE,NAME,NAMDAT,LINEBEG,LINEEND,LINEMAX,LINESP,LINELEN,RX,RXSTNG,X,NUM,D,SITEPAR,RXN,SKIP,RXSTING
S:$G(QUIT)="" QUIT=1 ;DEFAULT TO EXIT OUT
Q:$G(PSOFROM)="EDIT" ;IT'S COMING FROM EDIT MODE DON'T PRINT IHS/OKCAO/POC 4/19/2001
Q:QUIT ;QUIT THE RTN
D PARM Q:QUIT D BEGIN ;IHS/OKCAO/POC 1/9/2001 DON'T NEED TO OPEN DEVICE AS THIS RTN IS INSIDE APSPLBL
Q
;
DEV1 S IOP=$G(PSOLAP) D ^%ZIS Q:POP U IO
Q
;
PARM ;EP
D:'$D(PSOPAR) ^PSOLSET ;IHS/DSD/ENM 11/06/96
D PARMSET(PSOSITE)
Q
;
PARMSET(SITE) ;EP
S SITEPAR=$$GET1^DIQ(9009033,SITE,306) ; Signature Label parameter
S:$G(SITEPAR)="" SITEPAR="N"
S LINEBEG=$$GET1^DIQ(9009033,SITE,5) ;$P(%APSITE,"^",6)
S LINEEND=$$GET1^DIQ(9009033,SITE,6) ;$P(%APSITE,"^",7)
S LINEMAX=$$GET1^DIQ(9009033,SITE,4) ;$P(%APSITE,"^",5)
S LINESP=$$GET1^DIQ(9009033,SITE,9) ;$P(%APSITE,"^",10)
S LINELEN=$$GET1^DIQ(9009033,SITE,3) ;$P(%APSITE,"^",4)
S LINESKIP=$$GET1^DIQ(9009033,SITE,8) ;$P(%APSITE,"^",9)
S:LINESKIP="" LINESKIP=0
S:$G(SKIP)="" SKIP=0 ;DEFAULT TO DO NOT PRINT EXTRA BLANK LABELS
Q
;
BEGIN ;
Q:SITEPAR["N"
U IO
I SITEPAR["A" D @WHICH,REST Q
I SITEPAR["D"&$$MCD^AUPNPAT(DFN,DT) D @WHICH,REST Q
I SITEPAR["R"&$$MCR^AUPNPAT(DFN,DT) D @WHICH,REST Q
I SITEPAR["P"&$$PI^AUPNPAT(DFN,DT) D @WHICH,REST Q
Q
;
ONE ;
S RXSTNG=""
S X="" F S X=$O(APSQSTG(X)) Q:X="" D
.S APSQSTG=$TR(APSQSTG(X),","," ")
.S RXSTING=""
.F I=1:1 S RX=$P(APSQSTG," ",I) Q:RX="" D
..S RXSTING=RXSTING_" "_$P($G(^PSRX(RX,0)),"^",1)
.S RXSTNG=RXSTNG_RXSTING
Q
;
TWO S RXSTNG=""
S X="" F S X=$O(APSQSTG(X)) Q:X="" D
.S RXSTNG=RXSTNG_" "_$P(APSQSTG(X),"^",2)
Q
REST U IO
S APSQSTG="RX NUMBER(S)"_RXSTNG
D HDR
S LASTPCE=""
F I=1:1 S THISPCE=$P(APSQSTG," ",I) Q:THISPCE="" D
.I $L(LASTPCE_" "_THISPCE)>LINELEN D ;
..W !,?LINESP,LASTPCE
..S LASTPCE=THISPCE
..S LINE=LINE+1
..I LINE+2>LINEMAX D SIG,FOOT,HDR
..I 1
.E S LASTPCE=LASTPCE_" "_THISPCE
I $L(LASTPCE) W !,?LINESP,LASTPCE S LINE=LINE+1 ;WRITE THE LAST LINE
D SIG
D FOOT
D SKIP
Q
HDR ;HEADER INFO
S LINE=0
F D=1:1:LINEBEG W ! ;S LINE=LINE+1
S NAME=$P(^DPT(DFN,0),"^",1)
S HRN=$$HRN^AUPNPAT(DFN,DUZ(2))
S NAMHRN="PT: "_NAME_" ("_$$HRN^AUPNPAT(DFN,DUZ(2))_")"
I $L(NAMHRN)>LINELEN D
.S NAME=$E(NAME,1,($L(NAME)-($L(NAMHRN)-LINELEN)))
.S NAMHRN="PT: "_NAME_" ("_$$HRN^AUPNPAT(DFN,DUZ(2))_")"
S DATE="DT: "_$$FMTE^XLFDT(DT,"2D")
S DOB=$$FMTE^XLFDT($$DOB^AUPNPAT(DFN),"2DZ")
W !,?LINESP,NAMHRN S LINE=LINE+1
W !,?LINESP,DATE," DOB:",DOB S LINE=LINE+1
Q
;
SIG ;
W !,?LINESP,"SIGNATURE:" S LINE=LINE+1
Q
;
F L=LINE:1:(LINEMAX-1) W !
F K=1:1:LINEEND W !
Q
;
SKIP ;LINE FEED THE NUMBER OF LABELS INDICATED IN LINESKIP
;THIS PRINTS DEPENDING IF THIS RTN CALLED AT BEGINNING OR END OF PRINTING IN RTN APSPNE4
Q:'$G(SKIP) ;SO DON'T PRINT IF NO SKIP
F I=1:1:LINESKIP D
.S NUM=LINEBEG+LINEEND+LINEMAX
.F I=1:1:NUM W !
Q
;
;
EN1 ;EP
;COME HERE FROM OPTION TO PRINT/REPRINT SIGNATURE LABEL
;THIS SUBROUTINE DOES THE PRINTING OF THE SIGNATURE LABEL
;TO BE PLACED IN THE PATIENTS CHART IF THIS SITE
N APSPZZN ;IHS/DSD/ENM 02/24/97
N RX,RXSTRING,SKIP,PSOSD,APSPZDT,APSPBDT,PSORX,RXN,RXSTING,APSQSTG
N LASTPCE,THISPCE,I,J,K,L,LINE,NAME,NAMDAT,LINEBEG,LINEEND
N LINEMAX,LINESP,LINELEN,RX,RXSTNG,X,NUM,D,SITEPAR,PSOLIST
EPAGN ;
D PARM
S APSPQFLG=0,APSPEDT=0 K ARRAY,APSPFLG ;IHS/DSD/ENM 01/29/97
D PAT^APSPNUM Q:APSPQFLG!($G(PSORX("QFLG"))) ;IHS/BAO/DMH dmh added 3/1/2002
Q:'$D(PSODFN) ;IHS/MSC/PLS - 08/19/08
;
;
S APSPID=1 ;IHS/DSD/ENM 5/3/95 USED IN PSOLIST
S PSOOPT=-1,PSONUM="LIST" D EN^APSPNUM
I $G(Y(1))']"" D EMSG,EOJ Q
G:Y["^" EPAGN
D DEV
Q
DEV ;
S %ZIS="QM"
;IHS/CIA/PLS - 08/31/05 - Changed to prompt with either the Signature Label device or the Label device as the default
S %ZIS("A")="Enter SIGNATURE Device: " ;,IOP=$G(PSOLAP) D ^%ZIS
S %ZIS("B")=$S($L($P($G(APSQSGLB),U)):$P(APSQSGLB,U),1:$G(PSOLAP)) D ^%ZIS
I POP G EOJ
I $D(IO("Q")),IO=IO(0) W !!,"Sorry, you cannot queue to your screen or to a slave printer.",! K IO("Q") D ^%ZISC G DEV
;
I $D(IO("Q")) D D EOJ Q
.;S ZTRTN="EN2^APSQSIGN(.PSOLIST,0,1,""ONE"")",ZTIO=ION
.S ZTRTN="EN2^APSQSIGN",ZTIO=ION
.F G="DFN","PSOSITE","PSOPAR","PSONUM","PSOLIST(1)" S:$D(@G) ZTSAVE(G)=""
.S ZTDESC="Outpatient Pharm SIGNATURE Label"
.D ^%ZTLOAD
;
EN2 ;
I '$G(PSOLIST(1)) D EOJ Q
D PARMSET(PSOSITE)
S SITEPAR="A" ;default to ALL ;IHS/MSC/PLS - 08/08/2006
M APSQSTG=PSOLIST S QUIT=0,SKIP=1,WHICH="ONE"
D BEGIN
D ^%ZISC
D EOJ
Q
EMSG ;
W !,"No Rx's found for this date....!" H 2
Q
EOJ ;
K APSPID
Q
UTIL ;WHAT COMES IS FOR HELP AND INPUT TRANSFORM OF NEW FIELD IN APSP CONTROL FILE NOT DONE YET****
;PHARMACY 6.0;UTILITY TO SET VARIOUS FIELDS
;;
;FROM FIELD # OF FILE #
EXPL ;THIS IS THE EXPLANATION
W !,"THE ENTRY IN THIS FIELD DETERMINES WHETHER A SIGNATURE LABEL IS PRINTED."
W !,"A COMBINATION OF CODES CAN BE USED EXCEPT FOR 'A' OR 'N'."
W !
;
F I=1:1 S VAR=$P($T(LIST+I),";;",2) Q:VAR="" W !,VAR
LIST K VAR Q
;;D=MEDICAID PRESCRIPTIONS
;;R=MEDICARE PRESCRIPTIONS
;;P=PRIVATE INSURANCE PRESCRIPTIONS
;;A=ALL PRESCRIPTIONS
;;N=NO PRESCRIPTIONS
;
Q
EDIT ;THIS IS THE EDIT
S X=$TR(X,"BCEFGHIJKLMOQSTUVWXYZ")
I X'?1.3A K X W "GOT TO BE 1 TO 3 CHARACTERS" Q
S:X["A" X="A"
S:X["N" X="N"
I X["DD"!(X["RR")!(X["PP") K X Q
W " "_X
Q
APSQSIGN ;IHS/OKCAO/POC - RTN PRINTS SIGNATURE LABEL;19-Jan-2011 08:35;SM
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1003,1004,1005,1006,1007,1009,1010**;Sep 23, 2004
+2 ;ROUTINE TO WRITE SIGNATURE INFORMATION ON RX LABEL
+3 ; Modified - IHS/CIA/PLS - 01/13/04
+4 ; 03/21/05
+5 ; 10/26/05 - Line ENL+2
+6 ; IHS/MSC/PLS 03/01/06 - Line ZIS+11, added EN2+2
+7 ; 08/08/06 - Added line EN2+3
+8 ; 08/19/08 - Line EPAGN+4
+9 ; 04/30/10 - Line ENLT+5
+10 ; 01/19/11 - Line HDR+10
ENL(PPL,QUIT,SKIP,WHICH,PRT,SITE,NOQ) ; EP for use when site is printing on laser labels
+1 NEW PTYPE,ZTRTN,ZTIO,ZTDESC,ZTREQ,ZTSAVE
+2 ; IHS/CIA/PLS - 10/26/05 - Added ZTSK variable
NEW VAR,ZTSK
+3 SET PRT=$PIECE($GET(PRT),U)
SET PTYPE=$PIECE($GET(PRT),U,2)
+4 ; Requires a device
IF '$LENGTH($GET(PRT))
QUIT
+5 ; Set default for No-queue
SET NOQ=$GET(NOQ,0)
+6 IF NOQ
IF PRT=$GET(PSOLAP)
Begin DoDot:1
+7 DO ENLT
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 SET ZTRTN="ENLT^APSQSIGN"
+10 SET ZTDESC="Signature Label Print"
+11 SET ZTDTH=$HOROLOG
+12 SET ZTIO=PRT
+13 FOR VAR="SITE","PPL","QUIT","SKIP","WHICH"
IF $DATA(@VAR)
SET ZTSAVE(VAR)=""
+14 DO ^%ZTLOAD
End DoDot:1
+15 QUIT
ENLT ; Tasked entry point
+1 SET ZTREQ="@"
+2 NEW LP,RX,RX0,DFN,RXN,TMP,PSOFROM
+3 NEW LASTPCE,THISPCE,I,J,K,L,LINE,NAME,NAMDAT,LINEBEG,LINEEND
+4 NEW LINEMAX,LINESP,LINELEN,RX,RXSTNG,X,NUM,D,SITEPAR,RXN,RXSTING
+5 NEW DATE,DOB
+6 FOR LP=1:1
SET RX=$PIECE(PPL,",",LP)
IF RX=""
QUIT
Begin DoDot:1
+7 ; Build patient/script number array
+8 SET RX0=$GET(^PSRX(RX,0))
+9 SET DFN=$PIECE(RX0,U,2)
SET RXN=$PIECE(RX0,U)
+10 IF DFN
IF $LENGTH(RXN)
SET TMP(DFN,RXN)=""
End DoDot:1
+11 IF '$DATA(TMP)
QUIT
+12 ; Build array for printing
+13 SET DFN=0
FOR
SET DFN=$ORDER(TMP(DFN))
IF 'DFN
QUIT
Begin DoDot:1
+14 NEW APSQSTG,LP,RXN
+15 SET RXN=""
FOR LP=1:1
SET RXN=$ORDER(TMP(DFN,RXN))
IF RXN=""
QUIT
Begin DoDot:2
+16 SET APSQSTG(LP)=DFN_U_RXN
End DoDot:2
+17 DO PARMSET(SITE)
+18 DO BEGIN
End DoDot:1
+19 QUIT
EN(APSQSTG,QUIT,SKIP,WHICH) ;EP
+1 ;QUIT IS TO DECIDE IF WANT TO EXECUTE THIS RTN AT ALL
+2 ;SKIP IS PARAMETER TO DECIDE IF PRINT EXTRA BLANK LABELS
+3 ;LINESKIP IS THE NUMBER OF LABELS TO SKIP
+4 ;APSQSTG IS THE STRING OF RX NUMBERS TO WRITE
+5 ;SITEPAR IS THE PARAMETER TO DECIDE IF WRITE
+6 ;LINEBEG IS THE NUMBER OF LINES TO SKIP AT BEGINNING OF LABEL
+7 ;LINEEND IS THE NUMBER OF LINES TO SKIP AT END OF LABEL
+8 ;LINEMAX IS THE NUMBER OF LINES IN THE LABEL
+9 ;LINESP IS THE NUMBER OF SPACES TO START AT ON EACH LINE
+10 ;LINELEN IS THE MAX LENGTH OF A LINE
+11 ;LINE IS THE NUMBER OF LINES USED
+12 ;SITEPAR IS PARAMETER TO DECIDE UNDER WHAT CONDITIONS THIS RTN PRINTS FOUND IN APSP CONTROL FILE
+13 NEW LASTPCE,THISPCE,I,J,K,L,LINE,NAME,NAMDAT,LINEBEG,LINEEND,LINEMAX,LINESP,LINELEN,RX,RXSTNG,X,NUM,D,SITEPAR,RXN,SKIP,RXSTING
+14 ;DEFAULT TO EXIT OUT
IF $GET(QUIT)=""
SET QUIT=1
+15 ;IT'S COMING FROM EDIT MODE DON'T PRINT IHS/OKCAO/POC 4/19/2001
IF $GET(PSOFROM)="EDIT"
QUIT
+16 ;QUIT THE RTN
IF QUIT
QUIT
+17 ;IHS/OKCAO/POC 1/9/2001 DON'T NEED TO OPEN DEVICE AS THIS RTN IS INSIDE APSPLBL
DO PARM
IF QUIT
QUIT
DO BEGIN
+18 QUIT
+19 ;
DEV1 SET IOP=$GET(PSOLAP)
DO ^%ZIS
IF POP
QUIT
USE IO
+1 QUIT
+2 ;
PARM ;EP
+1 ;IHS/DSD/ENM 11/06/96
IF '$DATA(PSOPAR)
DO ^PSOLSET
+2 DO PARMSET(PSOSITE)
+3 QUIT
+4 ;
PARMSET(SITE) ;EP
+1 ; Signature Label parameter
SET SITEPAR=$$GET1^DIQ(9009033,SITE,306)
+2 IF $GET(SITEPAR)=""
SET SITEPAR="N"
+3 ;$P(%APSITE,"^",6)
SET LINEBEG=$$GET1^DIQ(9009033,SITE,5)
+4 ;$P(%APSITE,"^",7)
SET LINEEND=$$GET1^DIQ(9009033,SITE,6)
+5 ;$P(%APSITE,"^",5)
SET LINEMAX=$$GET1^DIQ(9009033,SITE,4)
+6 ;$P(%APSITE,"^",10)
SET LINESP=$$GET1^DIQ(9009033,SITE,9)
+7 ;$P(%APSITE,"^",4)
SET LINELEN=$$GET1^DIQ(9009033,SITE,3)
+8 ;$P(%APSITE,"^",9)
SET LINESKIP=$$GET1^DIQ(9009033,SITE,8)
+9 IF LINESKIP=""
SET LINESKIP=0
+10 ;DEFAULT TO DO NOT PRINT EXTRA BLANK LABELS
IF $GET(SKIP)=""
SET SKIP=0
+11 QUIT
+12 ;
BEGIN ;
+1 IF SITEPAR["N"
QUIT
+2 USE IO
+3 IF SITEPAR["A"
DO @WHICH
DO REST
QUIT
+4 IF SITEPAR["D"&$$MCD^AUPNPAT(DFN,DT)
DO @WHICH
DO REST
QUIT
+5 IF SITEPAR["R"&$$MCR^AUPNPAT(DFN,DT)
DO @WHICH
DO REST
QUIT
+6 IF SITEPAR["P"&$$PI^AUPNPAT(DFN,DT)
DO @WHICH
DO REST
QUIT
+7 QUIT
+8 ;
ONE ;
+1 SET RXSTNG=""
+2 SET X=""
FOR
SET X=$ORDER(APSQSTG(X))
IF X=""
QUIT
Begin DoDot:1
+3 SET APSQSTG=$TRANSLATE(APSQSTG(X),","," ")
+4 SET RXSTING=""
+5 FOR I=1:1
SET RX=$PIECE(APSQSTG," ",I)
IF RX=""
QUIT
Begin DoDot:2
+6 SET RXSTING=RXSTING_" "_$PIECE($GET(^PSRX(RX,0)),"^",1)
End DoDot:2
+7 SET RXSTNG=RXSTNG_RXSTING
End DoDot:1
+8 QUIT
+9 ;
TWO SET RXSTNG=""
+1 SET X=""
FOR
SET X=$ORDER(APSQSTG(X))
IF X=""
QUIT
Begin DoDot:1
+2 SET RXSTNG=RXSTNG_" "_$PIECE(APSQSTG(X),"^",2)
End DoDot:1
+3 QUIT
REST USE IO
+1 SET APSQSTG="RX NUMBER(S)"_RXSTNG
+2 DO HDR
+3 SET LASTPCE=""
+4 FOR I=1:1
SET THISPCE=$PIECE(APSQSTG," ",I)
IF THISPCE=""
QUIT
Begin DoDot:1
+5 ;
IF $LENGTH(LASTPCE_" "_THISPCE)>LINELEN
Begin DoDot:2
+6 WRITE !,?LINESP,LASTPCE
+7 SET LASTPCE=THISPCE
+8 SET LINE=LINE+1
+9 IF LINE+2>LINEMAX
DO SIG
DO FOOT
DO HDR
+10 IF 1
End DoDot:2
+11 IF '$TEST
SET LASTPCE=LASTPCE_" "_THISPCE
End DoDot:1
+12 ;WRITE THE LAST LINE
IF $LENGTH(LASTPCE)
WRITE !,?LINESP,LASTPCE
SET LINE=LINE+1
+13 DO SIG
+14 DO FOOT
+15 DO SKIP
+16 QUIT
HDR ;HEADER INFO
+1 SET LINE=0
+2 ;S LINE=LINE+1
FOR D=1:1:LINEBEG
WRITE !
+3 SET NAME=$PIECE(^DPT(DFN,0),"^",1)
+4 SET HRN=$$HRN^AUPNPAT(DFN,DUZ(2))
+5 SET NAMHRN="PT: "_NAME_" ("_$$HRN^AUPNPAT(DFN,DUZ(2))_")"
+6 IF $LENGTH(NAMHRN)>LINELEN
Begin DoDot:1
+7 SET NAME=$EXTRACT(NAME,1,($LENGTH(NAME)-($LENGTH(NAMHRN)-LINELEN)))
+8 SET NAMHRN="PT: "_NAME_" ("_$$HRN^AUPNPAT(DFN,DUZ(2))_")"
End DoDot:1
+9 SET DATE="DT: "_$$FMTE^XLFDT(DT,"2D")
+10 SET DOB=$$FMTE^XLFDT($$DOB^AUPNPAT(DFN),"2DZ")
+11 WRITE !,?LINESP,NAMHRN
SET LINE=LINE+1
+12 WRITE !,?LINESP,DATE," DOB:",DOB
SET LINE=LINE+1
+13 QUIT
+14 ;
SIG ;
+1 WRITE !,?LINESP,"SIGNATURE:"
SET LINE=LINE+1
+2 QUIT
+3 ;
+1 FOR L=LINE:1:(LINEMAX-1)
WRITE !
+2 FOR K=1:1:LINEEND
WRITE !
+3 QUIT
+4 ;
SKIP ;LINE FEED THE NUMBER OF LABELS INDICATED IN LINESKIP
+1 ;THIS PRINTS DEPENDING IF THIS RTN CALLED AT BEGINNING OR END OF PRINTING IN RTN APSPNE4
+2 ;SO DON'T PRINT IF NO SKIP
IF '$GET(SKIP)
QUIT
+3 FOR I=1:1:LINESKIP
Begin DoDot:1
+4 SET NUM=LINEBEG+LINEEND+LINEMAX
+5 FOR I=1:1:NUM
WRITE !
End DoDot:1
+6 QUIT
+7 ;
+8 ;
EN1 ;EP
+1 ;COME HERE FROM OPTION TO PRINT/REPRINT SIGNATURE LABEL
+2 ;THIS SUBROUTINE DOES THE PRINTING OF THE SIGNATURE LABEL
+3 ;TO BE PLACED IN THE PATIENTS CHART IF THIS SITE
+4 ;IHS/DSD/ENM 02/24/97
NEW APSPZZN
+5 NEW RX,RXSTRING,SKIP,PSOSD,APSPZDT,APSPBDT,PSORX,RXN,RXSTING,APSQSTG
+6 NEW LASTPCE,THISPCE,I,J,K,L,LINE,NAME,NAMDAT,LINEBEG,LINEEND
+7 NEW LINEMAX,LINESP,LINELEN,RX,RXSTNG,X,NUM,D,SITEPAR,PSOLIST
EPAGN ;
+1 DO PARM
+2 ;IHS/DSD/ENM 01/29/97
SET APSPQFLG=0
SET APSPEDT=0
KILL ARRAY,APSPFLG
+3 ;IHS/BAO/DMH dmh added 3/1/2002
DO PAT^APSPNUM
IF APSPQFLG!($GET(PSORX("QFLG")))
QUIT
+4 ;IHS/MSC/PLS - 08/19/08
IF '$DATA(PSODFN)
QUIT
+5 ;
+6 ;
+7 ;IHS/DSD/ENM 5/3/95 USED IN PSOLIST
SET APSPID=1
+8 SET PSOOPT=-1
SET PSONUM="LIST"
DO EN^APSPNUM
+9 IF $GET(Y(1))']""
DO EMSG
DO EOJ
QUIT
+10 IF Y["^"
GOTO EPAGN
+11 DO DEV
+12 QUIT
DEV ;
+1 SET %ZIS="QM"
+2 ;IHS/CIA/PLS - 08/31/05 - Changed to prompt with either the Signature Label device or the Label device as the default
+3 ;,IOP=$G(PSOLAP) D ^%ZIS
SET %ZIS("A")="Enter SIGNATURE Device: "
+4 SET %ZIS("B")=$SELECT($LENGTH($PIECE($GET(APSQSGLB),U)):$PIECE(APSQSGLB,U),1:$GET(PSOLAP))
DO ^%ZIS
+5 IF POP
GOTO EOJ
+6 IF $DATA(IO("Q"))
IF IO=IO(0)
WRITE !!,"Sorry, you cannot queue to your screen or to a slave printer.",!
KILL IO("Q")
DO ^%ZISC
GOTO DEV
+7 ;
+8 IF $DATA(IO("Q"))
Begin DoDot:1
+9 ;S ZTRTN="EN2^APSQSIGN(.PSOLIST,0,1,""ONE"")",ZTIO=ION
+10 SET ZTRTN="EN2^APSQSIGN"
SET ZTIO=ION
+11 FOR G="DFN","PSOSITE","PSOPAR","PSONUM","PSOLIST(1)"
IF $DATA(@G)
SET ZTSAVE(G)=""
+12 SET ZTDESC="Outpatient Pharm SIGNATURE Label"
+13 DO ^%ZTLOAD
End DoDot:1
DO EOJ
QUIT
+14 ;
EN2 ;
+1 IF '$GET(PSOLIST(1))
DO EOJ
QUIT
+2 DO PARMSET(PSOSITE)
+3 ;default to ALL ;IHS/MSC/PLS - 08/08/2006
SET SITEPAR="A"
+4 MERGE APSQSTG=PSOLIST
SET QUIT=0
SET SKIP=1
SET WHICH="ONE"
+5 DO BEGIN
+6 DO ^%ZISC
+7 DO EOJ
+8 QUIT
EMSG ;
+1 WRITE !,"No Rx's found for this date....!"
HANG 2
+2 QUIT
EOJ ;
+1 KILL APSPID
+2 QUIT
UTIL ;WHAT COMES IS FOR HELP AND INPUT TRANSFORM OF NEW FIELD IN APSP CONTROL FILE NOT DONE YET****
+1 ;PHARMACY 6.0;UTILITY TO SET VARIOUS FIELDS
+2 ;;
+3 ;FROM FIELD # OF FILE #
EXPL ;THIS IS THE EXPLANATION
+1 WRITE !,"THE ENTRY IN THIS FIELD DETERMINES WHETHER A SIGNATURE LABEL IS PRINTED."
+2 WRITE !,"A COMBINATION OF CODES CAN BE USED EXCEPT FOR 'A' OR 'N'."
+3 WRITE !
+4 ;
+5 FOR I=1:1
SET VAR=$PIECE($TEXT(LIST+I),";;",2)
IF VAR=""
QUIT
WRITE !,VAR
LIST KILL VAR
QUIT
+1 ;;D=MEDICAID PRESCRIPTIONS
+2 ;;R=MEDICARE PRESCRIPTIONS
+3 ;;P=PRIVATE INSURANCE PRESCRIPTIONS
+4 ;;A=ALL PRESCRIPTIONS
+5 ;;N=NO PRESCRIPTIONS
+6 ;
+7 QUIT
EDIT ;THIS IS THE EDIT
+1 SET X=$TRANSLATE(X,"BCEFGHIJKLMOQSTUVWXYZ")
+2 IF X'?1.3A
KILL X
WRITE "GOT TO BE 1 TO 3 CHARACTERS"
QUIT
+3 IF X["A"
SET X="A"
+4 IF X["N"
SET X="N"
+5 IF X["DD"!(X["RR")!(X["PP")
KILL X
QUIT
+6 WRITE " "_X
+7 QUIT
