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