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

PSOTALK.m

Go to the documentation of this file.
  1. PSOTALK ;BIR/EJW - SCRIPTALK INTERFACE FROM VISTA ;12/20/17 19:09
  1. ;;7.0;OUTPATIENT PHARMACY;**135,182,211,200,249,297,326,502**;DEC 1997;Build 13
  1. ;External reference ^PS(55 supported by DBIA 2228
  1. ;External reference to ^PSDRUG supported by DBIA 221
  1. ;External reference to ^PS(59.7 controlled subscription by DBIA 694
  1. ;External reference to WTEXT^PSSWRNA supported by DBIA 4444
  1. ;External reference to DRUG^PSSWRNA supported by DBIA 4449
  1. ;ROB SILVERMAN-HINES DEVELOPED ORIGINAL VISTA CUSTOM SOFTWARE FOR SCRIPTALK
  1. EN Q:'$$PAT55 ; QUIT IF NOT A SCRIPTALK ELIGIBLE PATIENT
  1. S PSOSTALK=1
  1. N PHONE,RXNUM,RXALPHA,DATE,EDATE,RFILLS,PTNAME,SIG,SIGX,PROV,DRUG,WARN,LINE
  1. D GATHER,TRANSQ,CLEAN
  1. Q
  1. ;
  1. CLEAN K PHONE,RXNUM,RXALPHA,DATE,EDATE,RFILLS,PTNAME,SIG,SIGX,PROV,DRUG,WARN,VADM
  1. K PSOCTP,PSOCTV,XMIT,PSORCT,PSOTSSN,PSOEXPDT
  1. K PSOLNE,PSOLEN,PSOLINE,PSOWORD,PSOWDS,LINE
  1. K PSOSIG1,PSOLSIG,PSOSIG,PSOSTOP,PSOPMAP
  1. Q
  1. BARE N RX,PSOPMAP,PSOTKBT,PSOTKRX,PSOTKDFN,PSOTKZT,ZTIO
  1. D CLEAN
  1. W ! S DIC="^PSRX(",DIC(0)="AEQM" D ^DIC K DIC Q:Y<0 S RX=+Y
  1. D:'$D(PSOPAR) ^PSOLSET
  1. I '$$PAT55 W !,"Patient not enrolled in ScripTalk program." G BAREO
  1. I $P(^PSRX(RX,"STA"),"^")'=0 W !,"Prescription not ACTIVE" G BAREO
  1. D GATHER
  1. W !!!,$S($G(PSOTKZT)'="`":" Queuing ScripTalk label",1:" *** UNABLE TO QUEUE SCRIPTALK LABEL ***")
  1. D TRANSQ
  1. BAREO D CLEAN
  1. W !!
  1. G BARE
  1. Q
  1. BARI N RX,PSOPMAP,PSOTKBT,PSOTKRX,PSOTKDFN,PSOTKZT,ZTIO
  1. D CLEAN
  1. S RX=$$READER^PSOTALK1("FO^1:12","Enter Barcode Rx#")
  1. Q:RX']""
  1. G:RX'["-" BARIO
  1. S RX=$P(RX,"-",2)
  1. I '$D(^PSRX(RX,0)) W !,"Prescription not on file" G BARIO
  1. I '$$PAT55 W !,"Patient not enrolled in ScripTalk program." G BARIO
  1. I $P(^PSRX(RX,"STA"),"^")'=0 W !,"Prescription not ACTIVE" G BARIO
  1. D:'$D(PSOPAR) ^PSOLSET
  1. D GATHER
  1. W !!!,$S($G(PSOTKZT)'="`":" Queuing ScripTalk label",1:" *** UNABLE TO QUEUE SCRIPTALK LABEL ***")
  1. D TRANSQ
  1. BARIO D CLEAN
  1. W !!
  1. G BARI
  1. Q
  1. GATHER ;
  1. N DFN
  1. S (DFN,PSOTKDFN)=$P(^PSRX(RX,0),"^",2),PSOTKRX=RX
  1. D DEM^VADPT
  1. S PHONE=$$PHONE
  1. S RXNUM=+$$RXNUM
  1. S RXALPHA=$$RXALPHA
  1. S DATE=$$DATE
  1. S FILLS=$$RFILLS I $L(RFILLS)=1 S FILLS="0"_FILLS
  1. S PTNAME=VADM(1) D
  1. .N FNAM,MI
  1. .S FNAM=$P(PTNAME,",",2) I FNAM[" " D
  1. ..S MI=$P(FNAM," ",2,99) I MI[" " S MI=$P(MI," ")
  1. ..S FNAM=$P(FNAM," ")
  1. .S PTNAME=FNAM_$S($G(MI)'="":" "_MI,1:"")_" "_$P(PTNAME,",")
  1. .S PTNAME=$$UP^XLFSTR(PTNAME)
  1. .S PTNAME=$TR(PTNAME,"-"," ")
  1. .S PTNAME=$TR(PTNAME,".","")
  1. .S PTNAME=$TR(PTNAME,"'"," ")
  1. D TRANS Q:$G(PSOTKBT)=""!(PSOTKZT="`")
  1. S SIG=$TR($$UP^XLFSTR($$SIGPOE),"[\]^_`{|}~","(/) -'( ) ")
  1. S SIGX=$TR($$UP^XLFSTR($$SIGPOEX),"[\]^_`{|}~","(/) -'( ) ")
  1. S PROV=$E($$UP^XLFSTR($$PROV),1,30)
  1. S DRUG=$TR($$UP^XLFSTR($$DRUG),"[\]^_`{|}~","(/) -'( ) ")
  1. S WARN=$$WARN
  1. D PSOEXP
  1. S LINE(1)="VAMC "_$$CITY_", "_$$STATE_" "_$$ZIP
  1. S LINE(2)=$$SITE_" ("_$$CLERK_"/"_$$VRPH_") "_$$ACODE_"-"_$$EPHON_" Exp: "_PSOEXPDT
  1. S LINE(3)="Rx# "_$$RXNUM_" "_$$EDATE_" Fill "_$$FILNO_" of "_$$TFILLS
  1. S LINE(4)=$$EPAT_" "_$$LAST4
  1. D INST^PSOTALK1 S LINE(5)=$G(PSOLNE(1)),LINE(6)=$G(PSOLNE(2)),LINE(7)=$G(PSOLNE(3))
  1. S LINE(8)=$$EPROV,LINE(10)=$$DRUG
  1. S LINE(9)="Qty: "_$$QTY_" "_$$DF
  1. Q
  1. TRANS ;If printer mapping defined use it; otherwise print by division 01/19/07
  1. D PCHK:'$D(PSOPMAP) ;don't recheck for mapped printer if PSOPMAP equal 0 (not defined) or 1 (defined)
  1. I '$D(^PS(59.7,1,47,"B",IOS))&('$G(PSOPMAP)) S PSOTKZT="`"_$P($G(^PS(59,PSOSITE,"STALK")),U),PSOTKBT=$S($P($G(^PS(59,PSOSITE,"STALK")),"^",3)=10:1,1:0)
  1. Q
  1. ;
  1. TRANSQ ;
  1. Q:$G(PSOTKBT)=""!(PSOTKZT="`")
  1. S ZTRTN="GO^PSOTALK",ZTSAVE("*")="",ZTDTH=$$NOW^XLFDT,ZTDESC="ScripTalk Interface Transmission",ZTIO=PSOTKZT
  1. D ^%ZTLOAD
  1. Q
  1. PCHK ;Check for printers that are mapped to a ScripTalk printer
  1. N PSOLPRT,PSONIOS,PSOLBSEQ
  1. S PSOTKZT="`",PSOLPRT=$S($D(PSOLAP):PSOLAP,$G(SUSPT):PSLION,$D(ION):ION,1:"") Q:PSOLPRT="" Q:'$D(^%ZIS(1,"B",PSOLPRT))
  1. S PSONIOS="",PSOPMAP=0,PSONIOS=$O(^%ZIS(1,"B",PSOLPRT,PSONIOS))
  1. I $D(^PS(59.7,1,47,"B",PSONIOS)) D
  1. . S PSOLBSEQ="",PSOLBSEQ=$O(^PS(59.7,1,47,"B",PSONIOS,PSOLBSEQ))
  1. . S PSOTKZT=PSOTKZT_$P(^PS(59.7,1,47,PSOLBSEQ,0),"^",2),PSOPMAP=1,PSOTKBT=$S($P($G(^PS(59.7,1,47,PSOLBSEQ,0)),"^",3)=10:1,1:0)
  1. Q
  1. ;
  1. GO W !,"^XA",!,"^FO250,700^XGE:RX.GRF^FS" ;;1.2e 4-17-02 TO MOVE GRAPHIC
  1. D OVERLAY,PICOTAG ;;FOR LARGER LABELS
  1. W !,"^PQ1,0,1,Y",!,"^XZ" ;;FOR LARGER LABELS
  1. S:$D(ZTQUEUED) ZTREQ="@"
  1. Q
  1. ;
  1. OVERLAY F PSOLINE=1:1:7 D DEFLINE((9+((20-PSOLINE)*28)),50,LINE(PSOLINE),PSOLINE,0)
  1. F PSOLINE=8:1:10 D DEFLINE((9+((19-PSOLINE)*28)),50,LINE(PSOLINE),PSOLINE,0)
  1. Q
  1. ;
  1. DEFLINE(XCORD,YCORD,PRTOUT,FIELDNO,OFFSET) ;
  1. W !,"^AFR,20,10^FO"_XCORD_","_YCORD_"^FR^CI0^FD"_PRTOUT_"^FS"
  1. Q
  1. ;
  1. PICOTAG S PSOCTP=1
  1. I PSOTKBT D SET10 Q
  1. S DRUG=$E(DRUG,1,39) ;1.2c*1 TEMPORARY FIX FOR DRUG TRUNCATE AT 39
  1. F XMIT=PTNAME,DRUG,SIGX,DATE,FILLS,WARN,PROV,PHONE,RXNUM,RXALPHA D XMITP
  1. Q
  1. ;
  1. XMITP W !,"^RX"_$S(PSOCTP<10:"0",1:"")_PSOCTP_","_XMIT_"^FS"
  1. S PSOCTP=PSOCTP+1
  1. Q
  1. ID() I $$PAT55 Q "+SCRIPTALK"
  1. E Q ""
  1. AUTO ;;v1.2c - LABEL REPRINTING FUNCTIONS 3-12-02
  1. Q:$G(PSOTREP) ;NO AUTO-PRINT DURING REGULAR NON-VOIDED LABEL REPRINT
  1. N PSOPMAP,PSOTKBT,PSOTKRX,PSOTKDFN,PSOTKZT,ZTIO
  1. D PCHK
  1. I $P($G(^PS(59,+PSOSITE,"STALK")),U,2)="A"!($G(PSOPMAP)) D EN
  1. Q
  1. ;
  1. PAT55() Q +$G(^PS(55,"ASTALK",$P(^PSRX(RX,0),"^",2))) ;IS PATIENT ENROLLED (NEW FIELD POSITION 2-12-02 RMS UPDATE v1.2b)
  1. PHONE() ;changes below 1.2c*1 to swap to site signed-on vs. site from Rx
  1. Q $E($P(^PS(59,+PSOSITE,0),"^",3),1,3)_$E($TR($P(^PS(59,+PSOSITE,0),"^",4),"-,",""),1,7) ; RX DIVISION PHONE NUMBER
  1. CITY() Q $P(^PS(59,+PSOSITE,0),"^",7)
  1. STATE() Q $P(^DIC(5,$P(^PS(59,+PSOSITE,0),"^",8),0),"^",2)
  1. ZIP() Q $P(^PS(59,+PSOSITE,0),"^",5)
  1. SITE() Q $P(^PS(59,+PSOSITE,0),"^",6)
  1. ACODE() Q $P(^PS(59,+PSOSITE,0),"^",3)
  1. EPHON() Q $P(^PS(59,+PSOSITE,0),"^",4)
  1. CLERK() Q $P($G(^PSRX(RX,"OR1")),"^",5)
  1. PSOEXP ;
  1. I 'PSOTKBT N X1,X2,X S X1=DT,X2=365 D C^%DTC S PSOEXPDT=X
  1. I PSOTKBT S PSOEXPDT=$P($G(^PSRX(RX,2)),"^",6)
  1. S PSOEXPDT=$E(PSOEXPDT,4,5)_"/"_$E(PSOEXPDT,6,7)_"/"_$E(PSOEXPDT,2,3)
  1. Q
  1. VRPH() Q $P($G(^PSRX(RX,2)),"^",10)
  1. RXNUM() Q $P(^PSRX(RX,0),"^",1) ;RETURN RX EXTERNAL NUMBER
  1. RXALPHA() ;RETURN RENEWAL LETTER OR SPACE CHARACTER
  1. N RXALPHA
  1. S RXALPHA=$E($P(^PSRX(RX,0),"^",1),$L($P(^PSRX(RX,0),"^",1)))
  1. Q $S(RXALPHA?1A:RXALPHA,1:" ")
  1. DATE() ;CHANGED 7-30-01 TO USE EDATE FORMAT ALSO WHEN SPEAKING
  1. S EDATE=$P(^PSRX(RX,3),"^")
  1. Q $E(EDATE,4,5)_$E(EDATE,6,7)_$E(EDATE,2,3)
  1. EDATE() Q $$FMTE^XLFDT($P(^PSRX(RX,3),"^")) ; EXTERNAL DATE / LAST DISPENSED
  1. FILLS() Q $G(RXF)+1 ; FILL COUNT
  1. TFILLS() Q $P(^PSRX(RX,0),"^",9)+1 ; TOTAL FILLS
  1. RFILLS() ;NEW REFILLS REMAINING METHOD 9-21-00, BASED ON PTST+5^PSORXVW
  1. S RFILLS=$P(^PSRX(RX,0),"^",9),PSORCT=0 F S PSORCT=$O(^PSRX(RX,1,PSORCT)) Q:'PSORCT S RFILLS=RFILLS-1
  1. Q RFILLS
  1. FILNO() Q $$TFILLS-$$RFILLS
  1. EPAT() Q $P(^DPT($P(^PSRX(RX,0),"^",2),0),"^") ; EXTERNAL PATIENT NAME
  1. LAST4() S PSOTSSN="" ; REMOVED LAST 4 SSN - PATCH *326
  1. Q PSOTSSN
  1. SIG() ;THIS SUBROUTINE WILL BE ABANDONED IF SIGPOE WORKS v1.2c 3-13-02
  1. I $L($P(^PSRX(RX,"SIG"),"^",1))=0 Q $E($$LSIG^PSOTALK1($P(^PSRX(RX,"SIG1",1,0),"^",1)),1,196)
  1. E Q $E($$LSIG^PSOTALK1($P(^PSRX(RX,"SIG"),"^",1)),1,196) ; SIG -- NEEDS TO BE EXPANDED
  1. SIGPOE() ;v1.2c - NEW SUBROUTINE TO GIVE MESSAGE FOR LONG SIGS FOR THE HUMAN READABLE PORTION
  1. S PSOSIG=""
  1. I $P($G(^PS(55,DFN,"LAN")),"^",1) D G SIGPOEE
  1. .S PSOSIG=" " ; PUT SPACE ON FRONT OF SIG (GETS STRIPPED OFF LATER)
  1. .D OTHL1^PSOLBL3(RX) I $O(SIG2(0))="" Q
  1. .N XX,X
  1. .;PSO*7*211;MODIFIED TO REPLACE SIG IF >138 INSTEAD OF 196
  1. .S XX=0 F S XX=$O(SIG2(XX)) Q:'XX S X=SIG2(XX) I X'="" S PSOSIG=PSOSIG_X I $L(PSOSIG)>138 D Q
  1. ..S PSOSIG=" THE SIG IS TOO LONG FOR PRINTED INSTRUCTIONS. >> REPRINT A NON-VOIDED RX LABEL AND AFFIX OVER THIS SCRIPTALK AUDIBLE LABEL."
  1. E D ;
  1. . N PSOSEQ
  1. . S PSOSTOP=0,PSOSIG=""
  1. . S PSOLSIG=" THE SIG IS TOO LONG FOR PRINTED INSTRUCTIONS. >> REPRINT A NON-VOIDED RX LABEL AND AFFIX OVER THIS SCRIPTALK AUDIBLE LABEL."
  1. . S PSOSEQ=0 F S PSOSEQ=$O(^PSRX(RX,"SIG1",PSOSEQ)) Q:PSOSEQ'=+PSOSEQ!($G(PSOSTOP)) D ;
  1. .. S PSOSIG1=$G(^PSRX(RX,"SIG1",PSOSEQ,0))
  1. ..;PSO*7*211;MODIFIED TO REPLACE SIG IF >138 INSTEAD OF 196
  1. .. I $L(PSOSIG)+$L($G(^PSRX(RX,"SIG1",PSOSEQ,0)))>138 S PSOSIG=PSOLSIG,PSOSTOP=1 Q ;
  1. .. S PSOSIG=$G(PSOSIG)_$S($G(PSOSIG)]"":"",1:" ")_PSOSIG1
  1. SIGPOEE Q:'PSOTKBT $E(PSOSIG,2,197) Q PSOSIG
  1. ;
  1. SIGPOEX() ;v1.2c - NEW SUBROUTINE TO GIVE MESSAGE FOR LONG SIGS FOR THE READ ALOUD PORTION
  1. S PSOSIG=""
  1. I $P($G(^PS(55,DFN,"LAN")),"^",1) D G SIGPOEEX
  1. .S PSOSIG=" " ; PUT SPACE ON FRONT OF SIG (GETS STRIPPED OFF LATER)
  1. .D OTHL1^PSOLBL3(RX) I $O(SIG2(0))="" Q
  1. .N XX,X
  1. .S XX=0 F S XX=$O(SIG2(XX)) Q:'XX S X=SIG2(XX) I X'="" S PSOSIG=PSOSIG_X I $L(PSOSIG)>196,'PSOTKBT D Q
  1. ..S PSOSIG=" LAS INSTRUCCIONES DE ESTA RECETA SON MUY LARGAS. POR FAVOR SOLICITE A SU CUIDADOR QUE LE LEA LAS INSTRUCCIONES IMPRESAS EN EL ROTULO O COMUNIQUESE CON SU MEDICO PARA INSTRUCCIONES COMPLETAS."
  1. I $L($P(^PSRX(RX,"SIG"),"^",1))'=0 Q:'PSOTKBT $E($$LSIG^PSOTALK1($P(^PSRX(RX,"SIG"),"^",1)),1,196) Q $$LSIG^PSOTALK1($P(^PSRX(RX,"SIG"),"^",1))
  1. E D ;
  1. . N PSOSEQ
  1. . S PSOSTOP=0,PSOSIG=""
  1. . S PSOLSIG=" THE INSTRUCTIONS FOR THIS PRESCRIPTION ARE TOO LONG. PLEASE HAVE A CAREGIVER READ THE PRINTED LABEL OR CONTACT YOUR PHYSICIAN FOR COMPLETE INSTRUCTIONS."
  1. . S PSOSEQ=0 F S PSOSEQ=$O(^PSRX(RX,"SIG1",PSOSEQ)) Q:PSOSEQ'=+PSOSEQ!($G(PSOSTOP)) D ;
  1. .. S PSOSIG1=$G(^PSRX(RX,"SIG1",PSOSEQ,0))
  1. .. I $L(PSOSIG)+$L($G(^PSRX(RX,"SIG1",PSOSEQ,0)))>196,'PSOTKBT S PSOSIG=PSOLSIG,PSOSTOP=1 Q ;
  1. .. S PSOSIG=$G(PSOSIG)_$S($G(PSOSIG)]"":"",1:" ")_PSOSIG1
  1. SIGPOEEX Q:'PSOTKBT $E(PSOSIG,2,197) Q PSOSIG
  1. PROV() ;PROVIDER NAME
  1. K DIC,X,Y S DIC="^VA(200,",DIC(0)="M",X="`"_+$P(^PSRX(RX,0),"^",4) D ^DIC S PSOPHYS=$S(+Y:$P(Y,"^",2),1:"UNKNOWN") K DIC,X,Y
  1. Q $P($$NAMEFMT^XLFNAME(PSOPHYS)," MD")
  1. EPROV() ;
  1. K DIC,X,Y S DIC="^VA(200,",DIC(0)="M",X="`"_+$P(^PSRX(RX,0),"^",4) D ^DIC S PSOPHYS=$S(+Y:$P(Y,"^",2),1:"UNKNOWN") K DIC,X,Y
  1. Q PSOPHYS
  1. QTY() Q $S($G(RXP):$P(RXP,"^",4),1:$P(^PSRX(RX,0),"^",7))
  1. DF() Q $P($G(^PSDRUG($P(^PSRX(RX,0),"^",6),660)),"^",8)
  1. DRUG() Q $$ZZ^PSOSUTL(RX) ; DRUG NAME
  1. WARN() N WARN,NWARN,IWARN,XWARN ; 1-28-02 UPDATE v1.2a TO ELIMINATE LOCAL CODES
  1. S WARN=$P(^PSDRUG($P(^PSRX(RX,0),"^",6),0),"^",8) ; WARNING LABEL CODES
  1. F NWARN=1:1:3 S IWARN=$P(WARN,",",NWARN) S:IWARN>20 IWARN="" S:$L(IWARN)=1 IWARN="0"_IWARN S:$L(IWARN)=0 IWARN="00" S XWARN=$G(XWARN)_IWARN
  1. Q XWARN
  1. ;
  1. SET10 ;Set readable data for 10K printers, 1280 max characters
  1. ;PSOTKLG("SIG")=Sig length
  1. ;PSOTKLG("WARN",#)=Individual warning length
  1. ;PSOTKLG("WARN","TOTAL")=Total warning length
  1. ;PSOTKLG("OTHER")=Total length of other fields
  1. ;PSOTKLG("LABEL")=Total label/heading length of RX11 including preceding spaces for data
  1. N PSOTKEX,PSOTKEXD,PSOTKQTY,PSOTKLD,PSOTKLDT,PSOTKDRG,PSODKDFU,PSOTKWR,PSOTKLAN,PSOTKLG,PSOTKWN,PSOTKLP,PSOTKWIN,PSOTKWRT,PSOTK11,PSOTKRNM,PSOTKPHN,PSOTKWTO,PSOTKLOP,PSOTKNUM,PSOTKZND
  1. S PSODKDFU=$$DF S PSOTKQTY="QUANTITY: "_$$QTY_$S(PSODKDFU'="":" "_PSODKDFU,1:"")
  1. S PSOTKEX=$P($G(^PSRX(PSOTKRX,2)),"^",6),PSOTKLD=$P($G(^PSRX(PSOTKRX,3)),"^"),PSOTKZND=$G(^PSRX(PSOTKRX,0)),PSOTKDRG=$P(PSOTKZND,"^",6),PSOTKNUM=$P(PSOTKZND,"^")
  1. S PSOTKEXD="EXPIRATION: "_$E(PSOTKEX,4,5)_"/"_$E(PSOTKEX,6,7)_"/"_(1700+($E(PSOTKEX,1,3)))
  1. S PSOTKLDT="DISPENSED ON: "_$E(PSOTKLD,4,5)_"/"_$E(PSOTKLD,6,7)_"/"_(1700+($E(PSOTKLD,1,3)))
  1. I $E($G(SIGX))'=" " S SIGX=" "_$G(SIGX)
  1. S PSOTKLG("SIG")=$L(SIGX)
  1. S PSOTKLAN=$P($G(^PS(55,PSOTKDFN,"LAN")),"^",2),PSOTKWR=$$DRUG^PSSWRNA(PSOTKDRG,PSOTKDFN)
  1. S PSOTKRNM="" F PSOTKLP=1:1:$L(PSOTKNUM) S PSOTKRNM=PSOTKRNM_$S(PSOTKLP>1:" ",1:"")_$E(PSOTKNUM,PSOTKLP)
  1. S (PSOTKLG("WARN","TOTAL"),PSOTKWTO)=0 I PSOTKWR'="" F PSOTKLP=1:1 S PSOTKWIN=$P(PSOTKWR,",",PSOTKLP) Q:PSOTKWIN="" D
  1. .S PSOTKWN=$$WTEXT^PSSWRNA(PSOTKWIN,PSOTKLAN) Q:PSOTKWN=""
  1. .S PSOTKWTO=PSOTKWTO+1 S PSOTKWRT(PSOTKWTO)=PSOTKWN,PSOTKLG("WARN",PSOTKWTO)=$L(PSOTKWN),PSOTKLG("WARN","TOTAL")=PSOTKLG("WARN","TOTAL")+$L(PSOTKWN)
  1. S PSOTKLG("LABEL")=58+$S('PSOTKWTO:0,1:(6*PSOTKWTO)) ; 58 = all label data including spaces, also including 2 semicolons in F13, minus 1 from leading space in Sig
  1. S PSOTKPHN=$S(PHONE="":" ",1:$$HLPHONE^HLFNC(PHONE))
  1. S PSOTKLG("OTHER")=$L(PTNAME)+$L(DRUG)+$L(SIGX)+$L(PSOTKLDT)+$L(PSOTKEXD)+$L(PSOTKQTY)+$L(FILLS)+$L(PROV)+$L(PSOTKPHN)+$L(PSOTKRNM)
  1. ;
  1. I PSOTKLG("LABEL")+PSOTKLG("OTHER")+PSOTKLG("WARN","TOTAL")<1281 D W !,PSOTK11 Q ;All data fits on RX11
  1. .S PSOTK11="^RX11,_F10 "_PTNAME_";_F11 "_DRUG_";_F12"_SIGX_";_F13 "_PSOTKLDT_";"_PSOTKEXD_";"_PSOTKQTY_";_F14 "_FILLS
  1. .F PSOTKLP=1:1 Q:$G(PSOTKWRT(PSOTKLP))="" D
  1. ..S PSOTK11=PSOTK11_";_F15 "_PSOTKWRT(PSOTKLP)
  1. .S PSOTK11=PSOTK11_";_F16 "_PROV_";_F17 "_PSOTKPHN_";_F18 "_PSOTKRNM_";^FS"
  1. ;
  1. I PSOTKLG("LABEL")+PSOTKLG("OTHER")>1280 D W !,PSOTK11 Q ;All Data (excluding Warnings) does not fit on label
  1. .S PSOTK11="^RX11,_F10 "_PTNAME_";_F11 "_DRUG_";_F12 "_$$SIGALL_";_F13 "_PSOTKLDT_";"_PSOTKEXD_";"_PSOTKQTY_";_F14 "_FILLS_$S(PSOTKWTO:";F15 "_$$WNALL,1:"")_";_F16 "_PROV_";_F17 "_PSOTKPHN_";_F18 "_PSOTKRNM_";^FS"
  1. ;
  1. ;rest of code is for when PSOTKGL("OTHER")+PSOTKLG("LABEL") fits on label but adding the warning(s) take you over:
  1. S PSOTKLG("REM")=1280-(PSOTKLG("OTHER")+PSOTKLG("LABEL")) ;Set remaining length to work with for warnings
  1. ;
  1. I 143>PSOTKLG("REM"),PSOTKLG("WARN","TOTAL")>PSOTKLG("REM") D W !,PSOTK11 Q ;Cannot fit any warnings on label
  1. .S PSOTK11="^RX11,_F10 "_PTNAME_";_F11 "_DRUG_";_F12 "_$$SIGALL_";_F13 "_PSOTKLDT_";"_PSOTKEXD_";"_PSOTKQTY_";_F14 "_FILLS_";F15 "_$$WNALL_";_F16 "_PROV_";_F17 "_PSOTKPHN_";_F18 "_PSOTKRNM_";^FS"
  1. ;
  1. ;Fit as many warnings as you can on label
  1. F PSOTKLP=1:1 Q:PSOTKLG("WARN",PSOTKLP)+148>PSOTKLG("REM") S PSOTKLG("REM")=PSOTKLG("REM")-(PSOTKLG("WARN",PSOTKLP)+6)
  1. S PSOTKLP=PSOTKLP-1
  1. S PSOTK11="^RX11,_F10 "_PTNAME_";_F11 "_DRUG_";_F12"_SIGX_";_F13 "_PSOTKLDT_";"_PSOTKEXD_";"_PSOTKQTY_";_F14 "_FILLS
  1. F PSOTKLOP=1:1:PSOTKLP D
  1. .S PSOTK11=PSOTK11_";_F15 "_PSOTKWRT(PSOTKLOP)
  1. S PSOTK11=PSOTK11_";_F15 "_$$WNREM_";_F16 "_PROV_";_F17 "_PSOTKPHN_";_F18 "_PSOTKRNM_";^FS"
  1. W !,PSOTK11 Q
  1. Q
  1. ;
  1. WNALL() ;Message when unable to print any warnings
  1. Q "Please note. No warnings could be included. Please ask a care giver or VHA professional to read the remainder of this information to you."
  1. ;
  1. WNREM() ;Message when only able to print some warnings
  1. Q "Please note. Not all warnings could be included. Please ask a care giver or VHA professional to read the remainder of this information to you."
  1. ;
  1. SIGALL() ;Sig plus all other information besides warnings is too long
  1. Q "Please note. Instructions "_$S(PSOTKWTO:"and warnings ",1:"")_"could not be included. Please ask a care giver or VHA professional to read the remainder of this information to you."