- 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 Feb 19, 2025@00:02:05 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."