Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APSPLBL1

APSPLBL1.m

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