APSPLBL1 ; IHS/DSD/ENM - PRINTS LABEL ;26-Feb-2013 13:53;DU
;;7.0;IHS PHARMACY MODIFICATIONS;**1003,1004,1009,1010,1015**;09/03/97;Build 62
; Modified - IHS/CIA/PLS - 01/16/04; 02/18/04
; - 05/24/05
; - 09/23/05
; IHS/MSC/PLS - 12/09/10 - Changed HRN calls to use field 100
; - 01/21/11 - Fixed typo at SUMMARY14
; IHS/MSC/MGH - 02/25/13 - Added variable check for reissue
;NOTE: VA Patches 31,66,60,59 not installed in this rtn IHS/DSD/ENM 3.9.94
;
EP ; This IHS routine is a rewrite of and not the same as the
; VA PSOLBL1 rtn.
;
M SGYY=SGY ; Save a copy of sig array before modification to be used for summary labels
Z S L=$L(PSZRM)
S SGC=$G(SGC,1)
I $L(SGY(SGC))+L+1<PSZW S SGY(SGC)=SGY(SGC)_$E(" ",1,PSZW-L-1-$L(SGY(SGC)))_PSZRM
E S SGC=SGC+1,SGY(SGC)=$E(" ",1,PSZW-L-2)_PSZRM
;
S COPIES=COPIES-$$EXTINF(RX,$G(REPRINT,0))
G:COPIES<1 SUM
;
START S N="",COPIES=COPIES-1 F I=1:1:PSZB W !
S PSZZL=4 I $D(LEXDT),LEXDT]"" S PSZZL=5 ; Set # of sig lines to print
S:APSPMAN=1!(APSPMAN=2) PSZZL=PSZZL+1
S PSZLA=PSZL-PSZZL
W !,?PSZTAB,$E(PNM,1,PSZW-8),?(PSZW+PSZTAB)-6 W $$HRN^AUPNPAT(DFN,$$GET1^DIQ(59,PSOSITE,100,"I"))
SIG ;
G CON:PSZLA<SGC F DR=1:1:PSZLA D SIG1
G NEXT
CON S (DR,F)=0
C1 F I=1:1:PSZL-2 S DR=DR+1 D SIG1 Q:'$D(SGY(DR+1))
I '$D(SGY(DR+1))&(I>PSZLA) F II=1:1:(PSZL-2-I) W !
I '$D(SGY(DR+1)) G NEXT:F&(I'>PSZLA)
W !,?PSZTAB,"**** CONTINUED ****" S F=1
F I=1:1:PSZE+PSZB W !
W !,?PSZTAB,"**** CONTINUED ****" S PSZM=$S(PSZLA-(SGC-DR)'<0:PSZLA-(SGC-DR),1:0) F I=1:1:PSZM W !
G C1:DR<SGC
;IHS/BAO/JCM;8/30/88 ABOVE SETS # OF PRINTABLE LINES FOR FORM FEED
;IHS/CIA/PLS - 09/23/05 - Changed quantity reference to QTY from 7th piece of zero node to resolve issues with incorrect refill quantity.
NEXT ;W !,?PSZTAB,DRUG S PSZQ="#"_$P(RXY,"^",7)_" "_APS("DISP UNITS") I $X+$L(PSZQ)+2<PSZW W " ",PSZQ S PSZQ=""
W !,?PSZTAB,DRUG S PSZQ="#"_$G(QTY)_" "_APS("DISP UNITS") I $X+$L(PSZQ)+2<PSZW W " ",PSZQ S PSZQ=""
I +$G(APSQDNDC)=0 W !,?PSZTAB,"Rx ",RXN,?$X+1,$S(VRPH:$$USRINI(VRPH),1:TECH),?(PSZTAB+16),PSZQ
E D
.S APSPZREF=+$O(^PSRX(RX,1,"A"),-1)
.S APSPZNDC=$S(APSPZREF:$$NDCVAL^APSPFUNC(RX,APSPZREF),1:$$NDCVAL^APSPFUNC(RX))
.W !,?PSZTAB,"Rx ",RXN," ["_APSPZNDC_"]",?$X+1,$S(VRPH:$$USRINI(VRPH),1:TECH),?(PSZTAB+16),PSZQ
.K APSPZNDC,APSPZREF
W !,?PSZTAB,$E($G(PHYS),1,17),?(PSZTAB+18),+$E(FDT,4,5),"-",$E(FDT,6,7),"-",$E(FDT,2,3)
I APSPMAN=1!(APSPMAN=2) W !,?PSZTAB,APSPMF_" "_APSPLOT_" Exp "_APSPDY ;IHS/DSD/ENM 12/16/96 Manufacturer data for label 8/18/2000 IHS/OKCAO/POC
F I=1:1:PSZE W !
;
;THE NEXT FEW LINE TESTS IF THE PRESCRIPTION IS A REFILL,RENEW OR
;A PARTIAL FOR USE IN PRINTING SUMMARY LABELS TO BE PLACED IN THE
;PATIENTS CHART.
SUM I $P(^APSPCTRL(PSOSITE,0),U,12)=1,COPIES<1 D SUMMARY
;
I COPIES>0 S SIDE=1 G START
ZZE ;IHS/DSD/ENM NEXT 6 LINES ADDED FOR LBL NODE 12/1/95
;STORE LABEL PRINT NODE
N RXF,I,IR,FDA
S RXF=0 F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I S RXF=I
S IR=0 F FDA=0:0 S FDA=$O(^PSRX(RX,"L",FDA)) Q:'FDA S IR=FDA
S IR=IR+1,^PSRX(RX,"L",0)="^52.032A^"_IR_"^"_IR
;IHS/MSC/MGH added for variable APSPREIS
;S ^PSRX(RX,"L",IR,0)=$$NOW^XLFDT_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_$S($G(PCOMX)]"":$G(PCOMX),1:"From RX number "_$P(^PSRX(RX,0),"^"))_$S($G(RXP):" (PARTIAL)",1:"")_$S($D(REPRINT):" (REPRINT)",1:"")_"^"_DUZ
S ^PSRX(RX,"L",IR,0)=$$NOW^XLFDT_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_$S($G(PCOMX)]"":$G(PCOMX),1:"From RX number "_$P(^PSRX(RX,0),"^"))_$S($G(RXP):" (PARTIAL)",1:"")_$S($D(REPRINT):$S($G(APSPREIS)=1:" (REISSUE)",1:" (REPRINT)"),1:"")_"^"_DUZ
S ^PSRX(RX,"TYPE")=0
END K %DT,ADDR,DEA,DR,DR1,DRX,DRUG,FDT,SGY,RXY,RXZ,RYY,RFLMSG,RFL,COPIES
K DOB,DRUG,LIM,LMI,LINE,PS,PS1,PS2,PSZZL,PSZLA,II,PSZM,INT,ISD,I1
K MW,MAIL,STATE,SIDE,SSNP,SS,ST,ST1,PATST,PRTFL,PHYS,PNM,S,SL
K SGC,APS("DISP UNITS"),SGYY,APSPREIS
Q
;
SIG1 S X=$S($D(SGY(DR)):SGY(DR),1:"") W !,?PSZTAB,X
Q
SUMMARY ;IHS/BAO/JCM;FEB 15,1988
;THESE LINES BUILD THE ARRAY FOR PRINTING A SUMMARY LABEL TO
;PLACE IN THE CHART OF REFILLS AND PARTIAL PRESCRIPTIONS.
;
;$E(PNM,1,PSZW-8) = THE PATIENTS NAME
;
;FDT = THE FILL DATE FOR THE PARTIAL OR REFILL
;
;THE NEXT THREE LINES SET UP THE DRUG NAME TAKING OFF
;ANY TAB,CAP,SOLN ABBREVIATIONS TO SAVE LENGTH
N LP,FIND,END,PSZDRUG
F FIND=" TAB"," CAP"," SUSP"," SOLN"," SYRUP" I DRUG[FIND S END=$F(DRUG,FIND)-($L(FIND)+1) Q
S:'$D(END) END=99
S PSZDRUG=$E(DRUG,1,END) ; = THE DRUG NAME
S APSHRN=$$HRN^AUPNPAT(DFN,$$GET1^DIQ(59,PSOSITE,100,"I"))
; RX = Prescription IEN
;RXN = Prescription Number
;QTY = THE QUANTITY ISSUED
;
S N=$G(N)+1,APSPZZN=$G(APSPZZN)+1
S SGYY=""
F LP=1:1:SGC Q:'$L($G(SGYY(LP))) S SGYY=SGYY_SGYY(LP) Q:$L(SGYY)>200 ; get 100+ characters of sig
;IHS/CIA/PLS - 09/23/05 - Changed quantity reference to QTY from 7th piece of zero node to resolve issues with incorrect refill quantity.
;S ARRAY(APSPZZN)=$E(PNM,1,PSZW-8)_"^"_RXN_"^"_PSZDRUG_"^"_$E(SGYY,1,200)_"^"_+$P(RXY,"^",7)_"^"_+FDT_"^"_APSHRN
S ARRAY(APSPZZN)=$E(PNM,1,PSZW-8)_"^"_RXN_"^"_PSZDRUG_"^"_$E(SGYY,1,200)_"^"_+$G(QTY)_"^"_+FDT_"^"_APSHRN
Q
; Return initials associated with user
USRINI(IEN) ;EP
Q:'IEN " "
Q $$GET1^DIQ(200,IEN,1)
; Call External Interface
; Input: RX - Prescription IEN
; REPRINT - If label is a reprint
; Returns: 0 - print label
; 1 - don't print label or subtract 1 from label count
EXTINF(RX,REPRINT) ;EP
N RET,EXT,$ET
S RET=0,EXT=0
S $ET="",$ZT="EXTERR^APSPLBL1"
I +$P($G(PSOPAR),U,30) D
.I +$P($G(PSOPAR),U,30)=2,'$G(REPRINT) D
..N X
..X $G(^APSPCTRL(PSOSITE,8)) S RET=+$G(X,0)
.X $G(^APSPCTRL(PSOSITE,9))
EXTERR Q RET
APSPLBL1 ; IHS/DSD/ENM - PRINTS LABEL ;26-Feb-2013 13:53;DU
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1003,1004,1009,1010,1015**;09/03/97;Build 62
+2 ; Modified - IHS/CIA/PLS - 01/16/04; 02/18/04
+3 ; - 05/24/05
+4 ; - 09/23/05
+5 ; IHS/MSC/PLS - 12/09/10 - Changed HRN calls to use field 100
+6 ; - 01/21/11 - Fixed typo at SUMMARY14
+7 ; IHS/MSC/MGH - 02/25/13 - Added variable check for reissue
+8 ;NOTE: VA Patches 31,66,60,59 not installed in this rtn IHS/DSD/ENM 3.9.94
+9 ;
EP ; This IHS routine is a rewrite of and not the same as the
+1 ; VA PSOLBL1 rtn.
+2 ;
+3 ; Save a copy of sig array before modification to be used for summary labels
MERGE SGYY=SGY
Z SET L=$LENGTH(PSZRM)
+1 SET SGC=$GET(SGC,1)
+2 IF $LENGTH(SGY(SGC))+L+1<PSZW
SET SGY(SGC)=SGY(SGC)_$EXTRACT(" ",1,PSZW-L-1-$LENGTH(SGY(SGC)))_PSZRM
+3 IF '$TEST
SET SGC=SGC+1
SET SGY(SGC)=$EXTRACT(" ",1,PSZW-L-2)_PSZRM
+4 ;
+5 SET COPIES=COPIES-$$EXTINF(RX,$GET(REPRINT,0))
+6 IF COPIES<1
GOTO SUM
+7 ;
START SET N=""
SET COPIES=COPIES-1
FOR I=1:1:PSZB
WRITE !
+1 ; Set # of sig lines to print
SET PSZZL=4
IF $DATA(LEXDT)
IF LEXDT]""
SET PSZZL=5
+2 IF APSPMAN=1!(APSPMAN=2)
SET PSZZL=PSZZL+1
+3 SET PSZLA=PSZL-PSZZL
+4 WRITE !,?PSZTAB,$EXTRACT(PNM,1,PSZW-8),?(PSZW+PSZTAB)-6
WRITE $$HRN^AUPNPAT(DFN,$$GET1^DIQ(59,PSOSITE,100,"I"))
SIG ;
+1 IF PSZLA<SGC
GOTO CON
FOR DR=1:1:PSZLA
DO SIG1
+2 GOTO NEXT
CON SET (DR,F)=0
C1 FOR I=1:1:PSZL-2
SET DR=DR+1
DO SIG1
IF '$DATA(SGY(DR+1))
QUIT
+1 IF '$DATA(SGY(DR+1))&(I>PSZLA)
FOR II=1:1:(PSZL-2-I)
WRITE !
+2 IF '$DATA(SGY(DR+1))
IF F&(I'>PSZLA)
GOTO NEXT
+3 WRITE !,?PSZTAB,"**** CONTINUED ****"
SET F=1
+4 FOR I=1:1:PSZE+PSZB
WRITE !
+5 WRITE !,?PSZTAB,"**** CONTINUED ****"
SET PSZM=$SELECT(PSZLA-(SGC-DR)'<0:PSZLA-(SGC-DR),1:0)
FOR I=1:1:PSZM
WRITE !
+6 IF DR<SGC
GOTO C1
+7 ;IHS/BAO/JCM;8/30/88 ABOVE SETS # OF PRINTABLE LINES FOR FORM FEED
+8 ;IHS/CIA/PLS - 09/23/05 - Changed quantity reference to QTY from 7th piece of zero node to resolve issues with incorrect refill quantity.
NEXT ;W !,?PSZTAB,DRUG S PSZQ="#"_$P(RXY,"^",7)_" "_APS("DISP UNITS") I $X+$L(PSZQ)+2<PSZW W " ",PSZQ S PSZQ=""
+1 WRITE !,?PSZTAB,DRUG
SET PSZQ="#"_$GET(QTY)_" "_APS("DISP UNITS")
IF $X+$LENGTH(PSZQ)+2<PSZW
WRITE " ",PSZQ
SET PSZQ=""
+2 IF +$GET(APSQDNDC)=0
WRITE !,?PSZTAB,"Rx ",RXN,?$X+1,$SELECT(VRPH:$$USRINI(VRPH),1:TECH),?(PSZTAB+16),PSZQ
+3 IF '$TEST
Begin DoDot:1
+4 SET APSPZREF=+$ORDER(^PSRX(RX,1,"A"),-1)
+5 SET APSPZNDC=$SELECT(APSPZREF:$$NDCVAL^APSPFUNC(RX,APSPZREF),1:$$NDCVAL^APSPFUNC(RX))
+6 WRITE !,?PSZTAB,"Rx ",RXN," ["_APSPZNDC_"]",?$X+1,$SELECT(VRPH:$$USRINI(VRPH),1:TECH),?(PSZTAB+16),PSZQ
+7 KILL APSPZNDC,APSPZREF
End DoDot:1
+8 WRITE !,?PSZTAB,$EXTRACT($GET(PHYS),1,17),?(PSZTAB+18),+$EXTRACT(FDT,4,5),"-",$EXTRACT(FDT,6,7),"-",$EXTRACT(FDT,2,3)
+9 ;IHS/DSD/ENM 12/16/96 Manufacturer data for label 8/18/2000 IHS/OKCAO/POC
IF APSPMAN=1!(APSPMAN=2)
WRITE !,?PSZTAB,APSPMF_" "_APSPLOT_" Exp "_APSPDY
+10 FOR I=1:1:PSZE
WRITE !
+11 ;
+12 ;THE NEXT FEW LINE TESTS IF THE PRESCRIPTION IS A REFILL,RENEW OR
+13 ;A PARTIAL FOR USE IN PRINTING SUMMARY LABELS TO BE PLACED IN THE
+14 ;PATIENTS CHART.
SUM IF $PIECE(^APSPCTRL(PSOSITE,0),U,12)=1
IF COPIES<1
DO SUMMARY
+1 ;
+2 IF COPIES>0
SET SIDE=1
GOTO START
ZZE ;IHS/DSD/ENM NEXT 6 LINES ADDED FOR LBL NODE 12/1/95
+1 ;STORE LABEL PRINT NODE
+2 NEW RXF,I,IR,FDA
+3 SET RXF=0
FOR I=0:0
SET I=$ORDER(^PSRX(RX,1,I))
IF 'I
QUIT
SET RXF=I
+4 SET IR=0
FOR FDA=0:0
SET FDA=$ORDER(^PSRX(RX,"L",FDA))
IF 'FDA
QUIT
SET IR=FDA
+5 SET IR=IR+1
SET ^PSRX(RX,"L",0)="^52.032A^"_IR_"^"_IR
+6 ;IHS/MSC/MGH added for variable APSPREIS
+7 ;S ^PSRX(RX,"L",IR,0)=$$NOW^XLFDT_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_$S($G(PCOMX)]"":$G(PCOMX),1:"From RX number "_$P(^PSRX(RX,0),"^"))_$S($G(RXP):" (PARTIAL)",1:"")_$S($D(REPRINT):" (REPRINT)",1:"")_"^"_DUZ
+8 SET ^PSRX(RX,"L",IR,0)=$$NOW^XLFDT_"^"_$S($GET(RXP):99-RXPI,1:RXF)_"^"_$SELECT($GET(PCOMX)]"":...
... $GET(PCOMX),1:"From RX number "_$PIECE(^PSRX(RX,0),"^"))_$SELECT($GET(RXP):" (PARTIAL)",1:"")_$SELECT($DATA(REPRINT):$SELECT($GET(APSPREIS)=1:" (REISSUE)",1:" (REPRINT)"),1:"")_"^"_DUZ
+9 SET ^PSRX(RX,"TYPE")=0
END KILL %DT,ADDR,DEA,DR,DR1,DRX,DRUG,FDT,SGY,RXY,RXZ,RYY,RFLMSG,RFL,COPIES
+1 KILL DOB,DRUG,LIM,LMI,LINE,PS,PS1,PS2,PSZZL,PSZLA,II,PSZM,INT,ISD,I1
+2 KILL MW,MAIL,STATE,SIDE,SSNP,SS,ST,ST1,PATST,PRTFL,PHYS,PNM,S,SL
+3 KILL SGC,APS("DISP UNITS"),SGYY,APSPREIS
+4 QUIT
+5 ;
SIG1 SET X=$SELECT($DATA(SGY(DR)):SGY(DR),1:"")
WRITE !,?PSZTAB,X
+1 QUIT
SUMMARY ;IHS/BAO/JCM;FEB 15,1988
+1 ;THESE LINES BUILD THE ARRAY FOR PRINTING A SUMMARY LABEL TO
+2 ;PLACE IN THE CHART OF REFILLS AND PARTIAL PRESCRIPTIONS.
+3 ;
+4 ;$E(PNM,1,PSZW-8) = THE PATIENTS NAME
+5 ;
+6 ;FDT = THE FILL DATE FOR THE PARTIAL OR REFILL
+7 ;
+8 ;THE NEXT THREE LINES SET UP THE DRUG NAME TAKING OFF
+9 ;ANY TAB,CAP,SOLN ABBREVIATIONS TO SAVE LENGTH
+10 NEW LP,FIND,END,PSZDRUG
+11 FOR FIND=" TAB"," CAP"," SUSP"," SOLN"," SYRUP"
IF DRUG[FIND
SET END=$FIND(DRUG,FIND)-($LENGTH(FIND)+1)
QUIT
+12 IF '$DATA(END)
SET END=99
+13 ; = THE DRUG NAME
SET PSZDRUG=$EXTRACT(DRUG,1,END)
+14 SET APSHRN=$$HRN^AUPNPAT(DFN,$$GET1^DIQ(59,PSOSITE,100,"I"))
+15 ; RX = Prescription IEN
+16 ;RXN = Prescription Number
+17 ;QTY = THE QUANTITY ISSUED
+18 ;
+19 SET N=$GET(N)+1
SET APSPZZN=$GET(APSPZZN)+1
+20 SET SGYY=""
+21 ; get 100+ characters of sig
FOR LP=1:1:SGC
IF '$LENGTH($GET(SGYY(LP)))
QUIT
SET SGYY=SGYY_SGYY(LP)
IF $LENGTH(SGYY)>200
QUIT
+22 ;IHS/CIA/PLS - 09/23/05 - Changed quantity reference to QTY from 7th piece of zero node to resolve issues with incorrect refill quantity.
+23 ;S ARRAY(APSPZZN)=$E(PNM,1,PSZW-8)_"^"_RXN_"^"_PSZDRUG_"^"_$E(SGYY,1,200)_"^"_+$P(RXY,"^",7)_"^"_+FDT_"^"_APSHRN
+24 SET ARRAY(APSPZZN)=$EXTRACT(PNM,1,PSZW-8)_"^"_RXN_"^"_PSZDRUG_"^"_$EXTRACT(SGYY,1,200)_"^"_+$GET(QTY)_"^"_+FDT_"^"_APSHRN
+25 QUIT
+26 ; Return initials associated with user
USRINI(IEN) ;EP
+1 IF 'IEN
QUIT " "
+2 QUIT $$GET1^DIQ(200,IEN,1)
+3 ; Call External Interface
+4 ; Input: RX - Prescription IEN
+5 ; REPRINT - If label is a reprint
+6 ; Returns: 0 - print label
+7 ; 1 - don't print label or subtract 1 from label count
EXTINF(RX,REPRINT) ;EP
+1 NEW RET,EXT,$ETRAP
+2 SET RET=0
SET EXT=0
+3 SET $ETRAP=""
SET $ZT="EXTERR^APSPLBL1"
+4 IF +$PIECE($GET(PSOPAR),U,30)
Begin DoDot:1
+5 IF +$PIECE($GET(PSOPAR),U,30)=2
IF '$GET(REPRINT)
Begin DoDot:2
+6 NEW X
+7 XECUTE $GET(^APSPCTRL(PSOSITE,8))
SET RET=+$GET(X,0)
End DoDot:2
+8 XECUTE $GET(^APSPCTRL(PSOSITE,9))
End DoDot:1
EXTERR QUIT RET
