PSOTALK ;BIR/EJW - SCRIPTALK INTERFACE FROM VISTA ; 2/21/08 4:26pm
;;7.0;OUTPATIENT PHARMACY;**135,182,211,200,249,297,326**;DEC 1997;Build 11
;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
;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,TRANS,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
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 !!," Queuing ScripTalk label"
D TRANS
BAREO D CLEAN
W !!
G BARE
Q
BARI N RX
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 !!," Queuing ScripTalk label"
D TRANS
BARIO D CLEAN
W !!
G BARI
Q
GATHER ;
N DFN
S DFN=$P(^PSRX(RX,0),"^",2)
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,"'"," ")
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 ZTIO="`"_$P($G(^PS(59,PSOSITE,"STALK")),U)
Q:ZTIO="`"
S ZTRTN="GO^PSOTALK",ZTSAVE("*")="",ZTDTH=$$NOW^XLFDT,ZTDESC="Scriptalk Interface Transmission"
D ^%ZTLOAD
Q
PCHK ;Check for printers that are mapped to a ScripTalk printer
N PSOLPRT,PSONIOS,PSOLBSEQ
S ZTIO="`",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 ZTIO=ZTIO_$P(^PS(59.7,1,47,PSOLBSEQ,0),"^",2),PSOPMAP=1
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
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
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 ;
N X1,X2,X S X1=DT,X2=365 D C^%DTC S PSOEXPDT=X
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=" INDICACIONES MUY LARGAS. IMPRIMA UNA ETIQUETA DE VISTA VALIDA Y APLIQUELA SOBRE ESTA ETIQUETA DE SCRIPTALK EN LA BOTELLA."
E D ;
. N PSOSEQ
. S PSOSTOP=0,PSOSIG=""
. S PSOLSIG=" SIG IS TOO LONG. REPRINT A NON-VOIDED VISTA LABEL AND PLACE OVER THIS SCRIPTALK 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)_" "_PSOSIG1
SIGPOEE Q $E(PSOSIG,2,197)
;
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 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 $E($$LSIG^PSOTALK1($P(^PSRX(RX,"SIG"),"^",1)),1,196)
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 S PSOSIG=PSOLSIG,PSOSTOP=1 Q ;
.. S PSOSIG=$G(PSOSIG)_" "_PSOSIG1
SIGPOEEX Q $E(PSOSIG,2,197)
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
PSOTALK ;BIR/EJW - SCRIPTALK INTERFACE FROM VISTA ; 2/21/08 4:26pm
+1 ;;7.0;OUTPATIENT PHARMACY;**135,182,211,200,249,297,326**;DEC 1997;Build 11
+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 ;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 TRANS
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
+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 !!," Queuing ScripTalk label"
+8 DO TRANS
BAREO DO CLEAN
+1 WRITE !!
+2 GOTO BARE
+3 QUIT
BARI NEW RX
+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 !!," Queuing ScripTalk label"
+12 DO TRANS
BARIO DO CLEAN
+1 WRITE !!
+2 GOTO BARI
+3 QUIT
GATHER ;
+1 NEW DFN
+2 SET DFN=$PIECE(^PSRX(RX,0),"^",2)
+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 SET SIG=$TRANSLATE($$UP^XLFSTR($$SIGPOE),"[\]^_`{|}~","(/) -'( ) ")
+20 SET SIGX=$TRANSLATE($$UP^XLFSTR($$SIGPOEX),"[\]^_`{|}~","(/) -'( ) ")
+21 SET PROV=$EXTRACT($$UP^XLFSTR($$PROV),1,30)
+22 SET DRUG=$TRANSLATE($$UP^XLFSTR($$DRUG),"[\]^_`{|}~","(/) -'( ) ")
+23 SET WARN=$$WARN
+24 DO PSOEXP
+25 SET LINE(1)="VAMC "_$$CITY_", "_$$STATE_" "_$$ZIP
+26 SET LINE(2)=$$SITE_" ("_$$CLERK_"/"_$$VRPH_") "_$$ACODE_"-"_$$EPHON_" Exp: "_PSOEXPDT
+27 SET LINE(3)="Rx# "_$$RXNUM_" "_$$EDATE_" Fill "_$$FILNO_" of "_$$TFILLS
+28 SET LINE(4)=$$EPAT_" "_$$LAST4
+29 DO INST^PSOTALK1
SET LINE(5)=$GET(PSOLNE(1))
SET LINE(6)=$GET(PSOLNE(2))
SET LINE(7)=$GET(PSOLNE(3))
+30 SET LINE(8)=$$EPROV
SET LINE(10)=$$DRUG
+31 SET LINE(9)="Qty: "_$$QTY_" "_$$DF
+32 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 ZTIO="`"_$PIECE($GET(^PS(59,PSOSITE,"STALK")),U)
+3 IF ZTIO="`"
QUIT
+4 SET ZTRTN="GO^PSOTALK"
SET ZTSAVE("*")=""
SET ZTDTH=$$NOW^XLFDT
SET ZTDESC="Scriptalk Interface Transmission"
+5 DO ^%ZTLOAD
+6 QUIT
PCHK ;Check for printers that are mapped to a ScripTalk printer
+1 NEW PSOLPRT,PSONIOS,PSOLBSEQ
+2 SET ZTIO="`"
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 ZTIO=ZTIO_$PIECE(^PS(59.7,1,47,PSOLBSEQ,0),"^",2)
SET PSOPMAP=1
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 ;1.2c*1 TEMPORARY FIX FOR DRUG TRUNCATE AT 39
SET DRUG=$EXTRACT(DRUG,1,39)
+2 FOR XMIT=PTNAME,DRUG,SIGX,DATE,FILLS,WARN,PROV,PHONE,RXNUM,RXALPHA
DO XMITP
+3 QUIT
+4 ;
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 DO PCHK
+3 IF $PIECE($GET(^PS(59,+PSOSITE,"STALK")),U,2)="A"!($GET(PSOPMAP))
DO EN
+4 QUIT
+5 ;
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 NEW X1,X2,X
SET X1=DT
SET X2=365
DO C^%DTC
SET PSOEXPDT=X
+2 SET PSOEXPDT=$EXTRACT(PSOEXPDT,4,5)_"/"_$EXTRACT(PSOEXPDT,6,7)_"/"_$EXTRACT(PSOEXPDT,2,3)
+3 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=" INDICACIONES MUY LARGAS. IMPRIMA UNA ETIQUETA DE VISTA VALIDA Y APLIQUELA SOBRE ESTA ETIQUETA DE SCRIPTALK EN LA BOTELLA."
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=" SIG IS TOO LONG. REPRINT A NON-VOIDED VISTA LABEL AND PLACE OVER THIS SCRIPTALK 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)_" "_PSOSIG1
End DoDot:2
End DoDot:1
SIGPOEE QUIT $EXTRACT(PSOSIG,2,197)
+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
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
QUIT $EXTRACT($$LSIG^PSOTALK1($PIECE(^PSRX(RX,"SIG"),"^",1)),1,196)
+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
SET PSOSIG=PSOLSIG
SET PSOSTOP=1
QUIT
+16 SET PSOSIG=$GET(PSOSIG)_" "_PSOSIG1
End DoDot:2
End DoDot:1
SIGPOEEX QUIT $EXTRACT(PSOSIG,2,197)
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
