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 ; 2/21/08 4:26pm
  1.  ;;7.0;OUTPATIENT PHARMACY;**135,182,211,200,249,297,326**;DEC 1997;Build 11
  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.  ;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,TRANS,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
  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 !!,"  Queuing ScripTalk label"
  1.  D TRANS
  1. BAREO D CLEAN
  1.  W !!
  1.  G BARE
  1.  Q
  1. BARI N RX
  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 !!,"  Queuing ScripTalk label"
  1.  D TRANS
  1. BARIO D CLEAN
  1.  W !!
  1.  G BARI
  1.  Q
  1. GATHER ;
  1.  N DFN
  1.  S DFN=$P(^PSRX(RX,0),"^",2)
  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.  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 ZTIO="`"_$P($G(^PS(59,PSOSITE,"STALK")),U)
  1.  Q:ZTIO="`"
  1.  S ZTRTN="GO^PSOTALK",ZTSAVE("*")="",ZTDTH=$$NOW^XLFDT,ZTDESC="Scriptalk Interface Transmission"
  1.  D ^%ZTLOAD
  1.  Q
  1. PCHK ;Check for printers that are mapped to a ScripTalk printer
  1.  N PSOLPRT,PSONIOS,PSOLBSEQ
  1.  S ZTIO="`",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 ZTIO=ZTIO_$P(^PS(59.7,1,47,PSOLBSEQ,0),"^",2),PSOPMAP=1
  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.  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.  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.  N X1,X2,X S X1=DT,X2=365 D C^%DTC S PSOEXPDT=X
  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=" INDICACIONES MUY LARGAS. IMPRIMA UNA ETIQUETA DE VISTA VALIDA Y APLIQUELA SOBRE ESTA ETIQUETA DE SCRIPTALK EN LA BOTELLA."
  1.  E  D  ;
  1.  . N PSOSEQ
  1.  . S PSOSTOP=0,PSOSIG=""
  1.  . S PSOLSIG=" SIG IS TOO LONG. REPRINT A NON-VOIDED VISTA LABEL AND PLACE OVER THIS SCRIPTALK 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)_" "_PSOSIG1
  1. SIGPOEE Q $E(PSOSIG,2,197)
  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 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 $E($$LSIG^PSOTALK1($P(^PSRX(RX,"SIG"),"^",1)),1,196)
  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 S PSOSIG=PSOLSIG,PSOSTOP=1 Q  ;
  1.  .. S PSOSIG=$G(PSOSIG)_" "_PSOSIG1
  1. SIGPOEEX Q $E(PSOSIG,2,197)
  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