Routine: APSQSIGN

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

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

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

DEV1 S IOP=$G(PSOLAP) D ^%ZIS Q:POP  U IO

PARM ;EP

 D:'$D(PSOPAR) ^PSOLSET   ;IHS/DSD/ENM 11/06/96

 D PARMSET(PSOSITE)

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

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

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

TWO S RXSTNG=""

 S X="" F  S X=$O(APSQSTG(X)) Q:X=""  D

 .S RXSTNG=RXSTNG_" "_$P(APSQSTG(X),"^",2)

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

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

SIG ;

 W !,?LINESP,"SIGNATURE:" S LINE=LINE+1

FOOT ;

 F L=LINE:1:(LINEMAX-1) W !

 F K=1:1:LINEEND W !

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 !

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

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

EMSG ;

 W !,"No Rx's found for this date....!" H 2

EOJ ;

 K APSPID

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

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

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       ;

FOOT      ;

 +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

APSQSIGN.m