PSOORUT1 ;BIR/SAB - Utility routine for oerr interface ;Jan 20, 2022@11:20:10
;;7.0;OUTPATIENT PHARMACY;**1,14,30,46,132,148,233,274,225,305,289,251,387,385,313,427,444,454,508,562,441**;DEC 1997;Build 208
;
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^PSXOPUTL supported by DBIA 2203
;called from HD^PSOORUTL
;
;Add Complex Orders to NVA Meds
;
REL ;removed order from hold
S ACT=1,ORS=0
I POERR("PSOFILNM")["S" S DA=+POERR("PSOFILNM") D G EXIT^PSOORUTL
.Q:'$D(^PS(52.41,DA,0)) Q:$P(^PS(52.41,DA,0),"^",3)="RF"
.S $P(^PS(52.41,DA,0),"^",3)="NW",POERR("STAT")="OR",POERR("FILLER")=DA_"^P"
.S:$G(POERR("COMM"))']"" POERR("COMM")="Order RELEASED from HOLD by OE/RR before finished." S $P(^PS(52.41,DA,4),"^")=POERR("COMM"),ORS=1
S DA=POERR("PSOFILNM") I $D(^PSRX(DA,0)) S ORS=1,PSDA=DA D G EXIT^PSOORUTL
.S POERR("FILLER")=DA_"^R",POERR("STAT")="OR"
.S:'$D(POERR("COMM")) POERR("COMM")="Prescription Released from HOLD by OE/RR"
.I DT>$P(^PSRX(DA,2),"^",6) D
..S EXP=$P(^PSRX(DA,2),"^",6) S:$P(^PSRX(DA,"STA"),"^")<12 $P(^PSRX(DA,"STA"),"^")=11,PSOEXFLG=1 S POERR("STAT")="UR",POERR("COMM")="Medication Expired on "_$E(EXP,4,5)_"/"_$E(EXP,6,7)_"/"_$E(EXP,2,3)_".",POERR("PHARMST")="" D ECAN^PSOUTL(DA) Q
.I $P(^PSRX(DA,"STA"),"^")'=16 S POERR("STAT")="UR",POERR("COMM")="Unable to Release from Hold" Q
.S RXFL(DA)=0,FDT=$P(^PSRX(DA,2),"^",2)
.I $O(^PSRX(DA,1,0)) F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S FDT=$P(^PSRX(DA,1,I,0),"^"),RXFL(DA)=I
.I FDT>DT N PSOSITEZ,ZPSOPAR6 S PSOSITEZ=$S($P($G(^PSRX(DA,2)),"^",9):$P(^(2),"^",9),1:$O(^PS(59,0))),ZPSOPAR6=$P($G(^PS(59,PSOSITEZ,1)),"^",6) I ZPSOPAR6 D Q
..S RXXDA=DA,DA=$O(^PS(52.5,"B",RXXDA,0)) I DA S DIK="^PS(52.5," D ^DIK K DIK
..S DA=RXXDA
..S DIC="^PS(52.5,",DIC(0)="L",DLAYGO=52.5,X=RXXDA,DIC("DR")=".02///"_FDT_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04///M;.05///0;.06////"_PSOSITEZ_";2///0;9///"_RXFL(DA) K DD,DO D FILE^DICN K RXFL,DD,DO
..S DA=RXXDA K RXXDA S $P(^PSRX(DA,"STA"),"^")=5,LFD=$E(FDT,4,5)_"-"_$E(FDT,6,7)_"-"_$E(FDT,2,3) D ACT1
..S PSOSUSZ=1
.E S $P(^PSRX(DA,"STA"),"^")=0
.S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1
.D ACT^PSOORUTL
.I $$SUBMIT^PSOBPSUT(DA) D ECMESND^PSOBPSU1(DA,"","",$S('$O(^PSRX(DA,1,0)):"OF",1:"RF"))
G EXIT^PSOORUTL
ACT1 I '$D(RXF) S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1
S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA
S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_POERR("USER")_"^"_RXF_"^"_"RX Placed on Suspense until "_LFD
Q
SUS ;
I $P($G(^PSRX(+$G(FILLER),"STA")),"^")=5 N PSOMSORR,PLACERXX D EN^PSOHLSN1(+$G(FILLER),"SC","ZS","")
Q
BLD ;builds med profile for Listman
K PSODCREV,^TMP("PSOPF",$J),PSOLST S:$G(PSOOPT)'=3 PSOOPT=0 I '$G(PSOSD),'$D(^XTMP("PSORRX1",$J,PSODFN)) S ^TMP("PSOPF",$J,1,0)="This patient has no prescriptions" S PSOCNT=0,PSOPF=1 Q
D EOJ,SHOW
EOJ ;
K PSOQFLG,PSODRG,PSODATA,PSOLF
Q
;-----------------------------------------------------------------
SHOW ;
; - ePharmacy modification to create a section for Rx with REJECTs
N PSOTMP,PSOSTS,PSODRNM,I,PSORX
S (PSOSTS,PSODRNM)=""
F S PSOSTS=$O(PSOSD(PSOSTS)) Q:PSOSTS="" D
. F S PSODRNM=$O(PSOSD(PSOSTS,PSODRNM)) Q:PSODRNM="" D
. . S PSORX=+$G(PSOSD(PSOSTS,PSODRNM))
. . ; PSO*7*427 - add a new section for open TRICARE/CHAMPVA/RRR rejects after the 79/88 open rejects
. . I PSOSTS="ACTIVE",$$FIND^PSOREJUT(PSORX,,,"79,88,943") S PSOTMP(" REJECT",PSODRNM)=PSOSTS Q ; DUR/RTS
. . I PSOSTS="ACTIVE",$$TRIC^PSOREJP1(PSORX),$$FIND^PSOREJUT(PSORX,,,,1) S PSOTMP(" REJECT2",PSODRNM)=PSOSTS Q ; TRI/CVA
. . I PSOSTS="ACTIVE",'$$TRIC^PSOREJP1(PSORX),$$FIND^PSOREJUT(PSORX,,,,,1) S PSOTMP(" REJECT2",PSODRNM)=PSOSTS Q ; RRR
. . S PSOTMP(PSOSTS,PSODRNM)=PSOSTS
;
S (PSOSTS,PSODRG)="",(PSOCNT,PSOQFLG,IEN)=0
K RN,DL S $P(RN," ",12)=" ",$P(DL," ",40)=" "
F PSCNT=0:0 S PSOSTS=$O(PSOTMP(PSOSTS)) Q:PSOSTS="" D
. D STA
. F PSOCT=0:0 S PSODRG=$O(PSOTMP(PSOSTS,PSODRG)) Q:PSODRG="" Q:PSOCNT>1000!PSOQFLG D
. . S PSOSTA=PSOTMP(PSOSTS,PSODRG)
. . S PSODATA=PSOSD(PSOSTA,PSODRG) I PSOSTA="ZNONVA" D NVA Q
. . S PSOCNT=PSOCNT+1 I PSOSTA="PENDING" D PEN Q
. . S:'$D(^PSRX(+PSODATA,0)) PSOCNT=PSOCNT-1 D:$D(^(0)) DISPL
;S (VALMCNT,PSOPF)=IEN
; bwf - 1/9/2014, PHARMACY INNOVATIONS. Adding display of remote rx's.
SHOWREM ;
N REMSITE,RRXIEN,RRXDAT,RRXDNAME,RRXDNL,RRXQTY,RRXQTYL,RREFILLS,RRXDSUPP,RRXEXP,RRXISSDT,RRXISSDT1,RRXLFDT,RRXLFDT1,RRXDNSP,RRXQSP,REMSIEN,STAT,STATABBR,DLINE,DLEN
N BSPACE,FSPACE,RSPACE,BDNAME,RRXISP,RXDUPP,PSORRLST
; SET UP PSORCNT
S PSORCNT=$G(PSOCNT)
I '$D(^TMP("PSOPF",$J)) S ^TMP("PSOPF",$J,1,0)="<No local prescriptions found.>",IEN=$G(IEN)+1
;S IEN=$G(IEN)+1,^TMP("PSOPF",$J,IEN,0)="-------------------------------------REMOTE-------------------------------------"
S REMSITE=0 F S REMSITE=$O(^XTMP("PSORRX1",$J,PSODFN,REMSITE)) Q:'REMSITE D
.I REMSITE=$G(DUZ(2)) Q
.;S REMSIEN=$O(^DIC(4,"D",REMSITE,0))
.S REMSIEN=$$FIND1^DIC(4,,"X",REMSITE,"D","I $P(^(0),U,11)=""N"",'$P($G(^(99)),U,4)") Q:'REMSIEN
.S STAT=0 F S STAT=$O(^XTMP("PSORRX1",$J,PSODFN,REMSITE,STAT)) Q:STAT="" D
..S STATABBR=$S(STAT="ACTIVE":"A",STAT="HOLD":"H",STAT="PROVIDER HOLD":"PH",STAT="SUSPENDED":"S",STAT["DISCONTINUED":"DC",STAT="EXPIRED":"E",1:"")
..S DLINE=$E($$GET1^DIQ(4,REMSIEN,.01,"E"),1,30)_" ("_REMSITE_")"_$S(STAT="ERR":"",1:" "_STAT),DLEN=$L(DLINE)
..S (FSPACE,RSPACE)=""
..S BSPACE=IOM-$L(DLINE),$P(FSPACE,"-",(BSPACE\2))="-",$P(RSPACE,"-",(BSPACE\2)+$S(BSPACE#2:1,1:0))="-"
..S IEN=$G(IEN)+1,^TMP("PSOPF",$J,IEN,0)=FSPACE_$E($$GET1^DIQ(4,REMSIEN,.01,"E"),1,30)_" ("_REMSITE_")"_$S(STAT="ERR":"",1:" "_STAT)_RSPACE
..I $D(^XTMP("PSORRX1",$J,PSODFN,REMSITE,"ERR")) S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=$G(^XTMP("PSORRX1",$J,PSODFN,REMSITE,"ERR"))
..S RRXDNAME="" F S RRXDNAME=$O(^XTMP("PSORRX1",$J,PSODFN,REMSITE,STAT,RRXDNAME)) Q:RRXDNAME="" D
...S RRXDAT=$G(^XTMP("PSORRX1",$J,PSODFN,REMSITE,STAT,RRXDNAME,0))
...S BDNAME=$E(RRXDNAME,1,35)
...S RRXIEN=$P(RRXDAT,U),RRXDNL=$L(BDNAME),RRXQTY=$P(RRXDAT,U,2),RRXQTYL=$L(RRXQTY),RREFILLS=$P(RRXDAT,U,3),RRXDSUPP=$E($P(RRXDAT,U,4),2,4),RRXEXP=$P(RRXDAT,U,5)
...S RRXISSDT=$P($P(RRXDAT,U,6),"."),RRXISSDT1=$E(RRXISSDT,5,6)_"-"_$E(RRXISSDT,7,8),RRXLFDT=$P($P(RRXDAT,U,8),"."),RRXLFDT1=$E(RRXLFDT,5,6)_"-"_$E(RRXLFDT,7,8)
...S IEN=$G(IEN)+1,PSORCNT=PSORCNT+1
...S (RRXDNSP,RRXISP)=""
...S RRXQSP=" "_STATABBR
...S $P(RRXISP," ",14-$L(RRXIEN))=" " ; length of Rx# varies
...S:RRXDNL+RRXQTYL>39 BDNAME=$E(BDNAME,1,$L(BDNAME)-(RRXDNL+RRXQTYL-39)),RRXDNL=$L(BDNAME)
...S $P(RRXDNSP," ",40-RRXQTYL-RRXDNL)=" "
...S $P(RRXQSP," ",4)=""
...I $L(STATABBR)=2 S RRXQSP=$E(RRXQSP,1,$L(RRXQSP)-1)
...S ^TMP("PSOPF",$J,IEN,0)=$J(PSORCNT,2)_$S($L(PSORCNT)<3:" ",1:"")_RRXIEN_RRXISP_BDNAME_RRXDNSP_RRXQTY_RRXQSP_RRXISSDT1_" "
...S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_RRXLFDT1_$S($L(RREFILLS)=1:" ",$L(RREFILLS=2):" ")_RREFILLS_$S($L(RRXDSUPP=2):" ",$L(RXDUPP=1):" ",1:" ")_RRXDSUPP
...S PSORRLST(PSORCNT)=IEN
...; PSO*7*454 - Need to specify this differently for remote rx's.
...; BWF 20161110 - LOOKING AT COUNT/DISPLAY
...;S PSOLST(PSOCNT)="R52^"_RRXIEN_U_"REMOTE"_U_REMSITE
...S PSOLST(PSORCNT)="R52^"_RRXIEN_U_"REMOTE"_U_REMSITE
S (VALMCNT,PSOPF)=IEN
SHOWX K DIRUT,DTOUT,DUOUT,DIROUT,PSODRG
Q
;
DISPL S IEN=IEN+1 N PSOID,PSOCMOP,STATLTH,ECME,TITRX,ORNUM,ERXIEN
K PSOLNT,PSOQTL,PSOLSP S PSOLRX=$S($G(^PSRX(+PSODATA,"IB")):13,1:14)-$L($P(^PSRX(+PSODATA,0),"^")),$P(PSOLNT," ",PSOLRX)=" ",PSODQL=$L($P(PSODRG,"^"))+$L($P(^PSRX(+PSODATA,0),"^",7))
I PSODQL<39 S $P(PSOQTL," ",(40-PSODQL))=" "
E S $P(PSOQTL," ",(52-$L($P(^PSRX(+PSODATA,0),"^",7))))=" ",$P(PSOLSP," ",(41-$L($P(PSODRG,"^"))))=" "
S ECME=$$ECME^PSOBPSUT(+PSODATA) I ECME'="" S PSOLNT=$E(PSOLNT,1,$L(PSOLNT)-1)
S TITRX=$$TITRX^PSOUTL(+PSODATA) I TITRX'="" S PSOLNT=$E(PSOLNT,1,$L(PSOLNT)-1)
; PSO*7*508 - eRx check and addition of the '&' character for eRx prescriptions and split line due to xindex lentgh failure
S ORNUM=$$GET1^DIQ(52,+PSODATA,39.3,"I")
I ORNUM S ERXIEN=$$CHKERX^PSOERXU1(ORNUM) I $G(ERXIEN) S PSOLNT=$E(PSOLNT,1,$L(PSOLNT)-2)
S ^TMP("PSOPF",$J,IEN,0)=$J(PSOCNT,2)_$S($L(PSOCNT)<3:" ",1:"")_$S($G(ERXIEN):"& ",1:"")_$P(^PSRX(+PSODATA,0),"^")
S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$S($G(^PSRX(+PSODATA,"IB")):"$",1:"")_ECME_TITRX_PSOLNT_$P(PSODRG,"^")_$S(PSODQL<39:PSOQTL_$P(^PSRX(+PSODATA,0),"^",7)_" ",1:$G(PSOLSP))
; PSO*7*508 - end eRx modification - consider also checking the Rx index in 52.49 for further accuracy
S STA="A^N^R^H^N^S^^^^^^E^DC^^DP^DE^HP^P^"
S PSOCMOP=""
I $D(^PSDRUG("AQ",$P(^PSRX(+PSODATA,0),"^",6))) S PSOCMOP=">"
N X S X="PSXOPUTL" X ^%ZOSF("TEST") K X I $T D
.N DA S DA=+PSODATA D ^PSXOPUTL K DA
.I $G(PSXZ(PSXZ("L")))=0!($G(PSXZ(PSXZ("L")))=2) S PSOCMOP="T"
.K PSXZ
S (STA,STATLTH)=$P(STA,"^",$P(PSODATA,"^",2)+1) D
.I $G(^PSRX(+PSODATA,"DDSTA"))]"" S (STATLTH,STA)="DD" Q
.I $G(^PSRX(+PSODATA,"PARK")),STA="A" S STA="AP" ;PAPI 441
.S (STATLTH,STA)=$S($P($G(^PSRX(+PSODATA,7)),"^")=1:"DA",$P($G(^PSRX(+PSODATA,7)),"^")=2:"DF",1:STA)
S STAPRT=STA_PSOCMOP,STATLTH=$L(STAPRT)
S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_STAPRT_$S(STATLTH=0:" ",STATLTH=1:" ",STATLTH=2:" ",1:"")
S PSOID=$P(^PSRX(+PSODATA,0),"^",13),PSOLF=+$G(^(3)),^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$E(PSOID,4,5)_"-"_$E(PSOID,6,7)_" "
N RFLZRO,PSOLRD S PSOLRD=$P($G(^PSRX(+PSODATA,2)),"^",13)
F PSOX=0:0 S PSOX=$O(^PSRX(+PSODATA,1,PSOX)) Q:'PSOX D
. S RFLZRO=$G(^PSRX(+PSODATA,1,PSOX,0))
. I +RFLZRO=PSOLF,$P(RFLZRO,"^",16) S PSOLF=PSOLF_"^R"
. S:$P(RFLZRO,"^",18)'="" PSOLRD=$P(RFLZRO,"^",18) I $P(RFLZRO,"^",16) S PSOLRD=PSOLRD_"^R"
K PSOX
I '$O(^PSRX(+PSODATA,1,0)),$P(^PSRX(+PSODATA,2),"^",15) S PSOLF=PSOLF_"^R",PSOLRD=PSOLRD_"^R"
S PSOLF=$S($G(PSOLF):$E(PSOLF,4,5),1:" ")_"-"_$S($G(PSOLF):$E(PSOLF,6,7),1:" ")_$S($P(PSOLF,"^",2)="R":"R ",1:" ")
S PSOLRD=$S($G(PSOLRD):$E(PSOLRD,4,5),1:" ")_"-"_$S($G(PSOLRD):$E(PSOLRD,6,7),1:" ")_$S($P(PSOLRD,"^",2)="R":"R ",1:" ")
S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$S($G(PSORFG):PSOLRD,1:PSOLF)
S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$J($P(PSODATA,"^",6),2)_" "_$J($P(PSODATA,"^",8),3)
;K SPC S PSOIND=$G(^PSRX(+PSODATA,6.5)) S:PSOIND'="" IEN=IEN+1,$P(SPC," ",20)=" ",^TMP("PSOPF",$J,IEN,0)=SPC_"INDICATION: "_PSOIND
;recently dc'd rxs
I $P($G(^PSRX(+PSODATA,3)),"^",5) D K X
.S X2=$S($P(PSOPAR,"^",33):$P(PSOPAR,"^",33),1:7),X1=$P(^PSRX(+PSODATA,3),"^",5) D C^%DTC
.I DT<X S PSODCREV(IEN)=IEN
;recently expired rxs
I $P($G(^PSRX(+PSODATA,2)),"^",6)<DT,'$P($G(^PSRX(+PSODATA,3)),"^",5) D K X
.S X2=$S($P(PSOPAR,"^",33):$P(PSOPAR,"^",33),1:7),X1=$P(^PSRX(+PSODATA,2),"^",6) D C^%DTC
.I DT<X S PSODCREV(IEN)=IEN
;
I (PSODQL>38)!$$BADADDFL^PSOUTIL(+PSODATA) D
.S IEN=IEN+1
.I PSODQL>38 S ^TMP("PSOPF",$J,IEN,0)=PSOQTL_"Qty: "_$P(^PSRX(+PSODATA,0),"^",7)
.I $$BADADDFL^PSOUTIL(+PSODATA) S $E(^TMP("PSOPF",$J,IEN,0),61)="*** Bad Address ***"
;
K PSOLNT,PSOQTL,PSOLSP,PSOLRX,PSODQL
S PSOLST(PSOCNT)="52^"_+PSODATA_"^"_PSOSTA
K PSODATA,PSOLF S PSOPF=IEN
Q
;
STA N LABEL,LINE,POS
S LABEL=PSOSTS,IEN=IEN+1
I PSOSTS="ZNONVA" S LABEL="Non-VA MEDS (Not dispensed by VA)"
I PSOSTS=" REJECT" S LABEL="REFILL TOO SOON/DUR REJECTS (Third Party)"
I PSOSTS=" REJECT2" S LABEL="OTHER REJECTS PENDING RESOLUTION" ;PSO*7*427 added new section
S POS=80-$L(LABEL)/2,$P(LINE,"-",81)="",$E(LINE,POS+1,POS+$L(LABEL))=LABEL
S ^TMP("PSOPF",$J,IEN,0)=LINE
Q
PENX S PSOLST(PSOCNT)="52.41^"_$P(PSODATA,"^",10)_"^"_PSOSTA
;K SPC S ENTRY=$P(PSODATA,"^",10),PSOIND=$P($G(^PS(52.41,ENTRY,4)),"^",2) S:PSOIND'="" IEN=IEN+1,$P(SPC," ",5)=" ",^TMP("PSOPF",$J,IEN,0)=SPC_"INDICATION: "_PSOIND
K PSODATA,PSOLF,RN,PSOLSP,PSOQTL,PSOLNT
Q
PEN ;
N PSOQTL,PSOLNT,PSOLNTZ,PSOQTLX,PSCMOPF,SPACEZ,ORNUM,ERXIEN
Q:'$D(^PS(52.41,$P(PSODATA,"^",10),0))
S PSCMOPF=0 I $P($G(PSODATA),"^",11),$D(^PSDRUG("AQ",$P(PSODATA,"^",11))) S PSCMOPF=1
; PSO*7*508 - eRx check and addition of the '&' character for eRx prescriptions
S ORNUM=$$GET1^DIQ(52.41,$P(PSODATA,U,10),.01,"I")
I ORNUM S ERXIEN=$$CHKERX^PSOERXU1(ORNUM)
S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=$J(PSOCNT,2)_$S($L(PSOCNT)<3:" ",1:"")_$S($G(ERXIEN):"& ",1:"")_$P(PSODRG,"^")
; PSO*7*508 - end eRx modification
I $P($G(^PS(52.41,+$P(PSODATA,"^",10),0)),"^",23)=1 S ^TMP("PSOPF",$J,IEN,"RV")=""
S PSOLNT=$L($P(PSODRG,"^")),PSOLNTZ=$L($P(PSODATA,"^",8))
; PSO*7*508 - adjust PSOLNT if this is an eRx
I $G(ERXIEN) S PSOLNT=PSOLNT+2
S $P(PSOQTLX," ",(11-PSOLNTZ))=" "
S:PSOLNT<37 $P(PSOQTL," ",(37-PSOLNT))=" "
I PSOLNT<38 D G PENX
.I PSOLNT=37 S PSOQTL=""
.I $P(^PS(52.41,$P(PSODATA,"^",10),0),"^",3)="RF" S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$G(PSOQTL)_" Refill Request Rx #: "_$P(^PSRX($P(^PS(52.41,$P(PSODATA,"^",10),0),"^",19),0),"^") Q
.S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$G(PSOQTL)_" "_"QTY: "_$P(PSODATA,"^",8)_$G(PSOQTLX)_" ISDT: "_$S('$P(PSODATA,"^",9):" ",1:$E($P(PSODATA,"^",9),4,5)_"-"_$E($P(PSODATA,"^",9),6,7))_$S($G(PSCMOPF):"> ",1:" ")
.S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_"REF: "_$S($L($P(PSODATA,"^",6))>1:"",1:" ")_$P(PSODATA,"^",6)
S IEN=IEN+1,$P(SPACEZ," ",42)=" "
I $P(^PS(52.41,$P(PSODATA,"^",10),0),"^",3)="RF" S ^TMP("PSOPF",$J,IEN,0)=SPACEZ_"Refill Request Rx #: "_$P(^PSRX($P(^PS(52.41,$P(PSODATA,"^",10),0),"^",19),0),"^") G PENX
S ^TMP("PSOPF",$J,IEN,0)=SPACEZ_"QTY: "_$P(PSODATA,"^",8)_$G(PSOQTLX)_" ISDT: "_$S('$P(PSODATA,"^",9):" ",1:$E($P(PSODATA,"^",9),4,5)_"-"_$E($P(PSODATA,"^",9),6,7))_$S($G(PSCMOPF):"> ",1:" ")_"REF: "_$S($L($P(PSODATA,"^",6))>1:"",1:" ")
S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",6)
G PENX
;
NVA ; Setting the Non-VA Meds on the Medication Profile Screen (ListMan) *modified listman to a new look to accomodate complex orders
S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=" "_$P(PSODRG,"^")_" " ;drug name
S:($L(^TMP("PSOPF",$J,IEN,0))+$L($P(PSODATA,"^",6))>80) IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=" "
S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",6)_" " ;dosage
S:($L(^TMP("PSOPF",$J,IEN,0))+$L($P(PSODATA,"^",8))>80) IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=" "
S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",8)_" " ;sched
I $P(PSODATA,"^",12)]"" D ;dura opt.
. S:($L(^TMP("PSOPF",$J,IEN,0))+$L($P(PSODATA,"^",12))>80) IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=" "
. S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_"FOR "_$P(PSODATA,"^",12)_" " ;dura
I $P(PSODATA,"^",13)]"" D Q ;conj opt. if present quit so next complex drug on new line
. S:($L(^TMP("PSOPF",$J,IEN,0))+$L($P(PSODATA,"^",13))>78) IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=" "
. S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_"-"_$P(PSODATA,"^",13)_"-" ;conj
;print date documented info @ col 62
S:($L(^TMP("PSOPF",$J,IEN,0)))>62 IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=" "
I $L(^TMP("PSOPF",$J,IEN,0))<62 F S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_" " Q:$L(^TMP("PSOPF",$J,IEN,0))>61 ;space fill to 62
S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_"Date Doc: "_$E($P(PSODATA,"^",9),4,5)_"/"_$E($P(PSODATA,"^",9),6,7)_"/"_$E($P(PSODATA,"^",9),2,3)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOORUT1 15586 printed Apr 09, 2024@21:36:03 Page 2
PSOORUT1 ;BIR/SAB - Utility routine for oerr interface ;Jan 20, 2022@11:20:10
+1 ;;7.0;OUTPATIENT PHARMACY;**1,14,30,46,132,148,233,274,225,305,289,251,387,385,313,427,444,454,508,562,441**;DEC 1997;Build 208
+2 ;
+3 ;External reference to ^PSDRUG supported by DBIA 221
+4 ;External reference to ^PSXOPUTL supported by DBIA 2203
+5 ;called from HD^PSOORUTL
+6 ;
+7 ;Add Complex Orders to NVA Meds
+8 ;
REL ;removed order from hold
+1 SET ACT=1
SET ORS=0
+2 IF POERR("PSOFILNM")["S"
SET DA=+POERR("PSOFILNM")
Begin DoDot:1
+3 if '$DATA(^PS(52.41,DA,0))
QUIT
if $PIECE(^PS(52.41,DA,0),"^",3)="RF"
QUIT
+4 SET $PIECE(^PS(52.41,DA,0),"^",3)="NW"
SET POERR("STAT")="OR"
SET POERR("FILLER")=DA_"^P"
+5 if $GET(POERR("COMM"))']""
SET POERR("COMM")="Order RELEASED from HOLD by OE/RR before finished."
SET $PIECE(^PS(52.41,DA,4),"^")=POERR("COMM")
SET ORS=1
End DoDot:1
GOTO EXIT^PSOORUTL
+6 SET DA=POERR("PSOFILNM")
IF $DATA(^PSRX(DA,0))
SET ORS=1
SET PSDA=DA
Begin DoDot:1
+7 SET POERR("FILLER")=DA_"^R"
SET POERR("STAT")="OR"
+8 if '$DATA(POERR("COMM"))
SET POERR("COMM")="Prescription Released from HOLD by OE/RR"
+9 IF DT>$PIECE(^PSRX(DA,2),"^",6)
Begin DoDot:2
+10 SET EXP=$PIECE(^PSRX(DA,2),"^",6)
if $PIECE(^PSRX(DA,"STA"),"^")<12
SET $PIECE(^PSRX(DA,"STA"),"^")=11
SET PSOEXFLG=1
SET POERR("STAT")="UR"
SET POERR("COMM")="Medication Expired on "_$EXTRACT(EXP,4,5)_"/"_$EXTRACT(EXP,6,7)_"/"_$EXTRACT(EXP,2,3)_"."
SET POERR("PHARMST")=""
DO ECAN^PSOUTL(DA)
QUIT
End DoDot:2
+11 IF $PIECE(^PSRX(DA,"STA"),"^")'=16
SET POERR("STAT")="UR"
SET POERR("COMM")="Unable to Release from Hold"
QUIT
+12 SET RXFL(DA)=0
SET FDT=$PIECE(^PSRX(DA,2),"^",2)
+13 IF $ORDER(^PSRX(DA,1,0))
FOR I=0:0
SET I=$ORDER(^PSRX(DA,1,I))
if 'I
QUIT
SET FDT=$PIECE(^PSRX(DA,1,I,0),"^")
SET RXFL(DA)=I
+14 IF FDT>DT
NEW PSOSITEZ,ZPSOPAR6
SET PSOSITEZ=$SELECT($PIECE($GET(^PSRX(DA,2)),"^",9):$PIECE(^(2),"^",9),1:$ORDER(^PS(59,0)))
SET ZPSOPAR6=$PIECE($GET(^PS(59,PSOSITEZ,1)),"^",6)
IF ZPSOPAR6
Begin DoDot:2
+15 SET RXXDA=DA
SET DA=$ORDER(^PS(52.5,"B",RXXDA,0))
IF DA
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK
+16 SET DA=RXXDA
+17 SET DIC="^PS(52.5,"
SET DIC(0)="L"
SET DLAYGO=52.5
SET X=RXXDA
SET DIC("DR")=".02///"_FDT_";.03////"_$PIECE(^PSRX(DA,0),"^",2)_";.04///M;.05///0;.06////"_PSOSITEZ_";2///0;9///"_RXFL(DA)
KILL DD,DO
DO FILE^DICN
KILL RXFL,DD,DO
+18 SET DA=RXXDA
KILL RXXDA
SET $PIECE(^PSRX(DA,"STA"),"^")=5
SET LFD=$EXTRACT(FDT,4,5)_"-"_$EXTRACT(FDT,6,7)_"-"_$EXTRACT(FDT,2,3)
DO ACT1
+19 SET PSOSUSZ=1
End DoDot:2
QUIT
+20 IF '$TEST
SET $PIECE(^PSRX(DA,"STA"),"^")=0
+21 SET RXF=0
FOR I=0:0
SET I=$ORDER(^PSRX(DA,1,I))
if 'I
QUIT
SET RXF=I
if I>5
SET RXF=I+1
+22 DO ACT^PSOORUTL
+23 IF $$SUBMIT^PSOBPSUT(DA)
DO ECMESND^PSOBPSU1(DA,"","",$SELECT('$ORDER(^PSRX(DA,1,0)):"OF",1:"RF"))
End DoDot:1
GOTO EXIT^PSOORUTL
+24 GOTO EXIT^PSOORUTL
ACT1 IF '$DATA(RXF)
SET RXF=0
FOR I=0:0
SET I=$ORDER(^PSRX(DA,1,I))
if 'I
QUIT
SET RXF=I
if I>5
SET RXF=I+1
+1 SET IR=0
FOR FDA=0:0
SET FDA=$ORDER(^PSRX(DA,"A",FDA))
if 'FDA
QUIT
SET IR=FDA
+2 SET IR=IR+1
SET ^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
+3 DO NOW^%DTC
SET ^PSRX(DA,"A",IR,0)=%_"^S^"_POERR("USER")_"^"_RXF_"^"_"RX Placed on Suspense until "_LFD
+4 QUIT
SUS ;
+1 IF $PIECE($GET(^PSRX(+$GET(FILLER),"STA")),"^")=5
NEW PSOMSORR,PLACERXX
DO EN^PSOHLSN1(+$GET(FILLER),"SC","ZS","")
+2 QUIT
BLD ;builds med profile for Listman
+1 KILL PSODCREV,^TMP("PSOPF",$JOB),PSOLST
if $GET(PSOOPT)'=3
SET PSOOPT=0
IF '$GET(PSOSD)
IF '$DATA(^XTMP("PSORRX1",$JOB,PSODFN))
SET ^TMP("PSOPF",$JOB,1,0)="This patient has no prescriptions"
SET PSOCNT=0
SET PSOPF=1
QUIT
+2 DO EOJ
DO SHOW
EOJ ;
+1 KILL PSOQFLG,PSODRG,PSODATA,PSOLF
+2 QUIT
+3 ;-----------------------------------------------------------------
SHOW ;
+1 ; - ePharmacy modification to create a section for Rx with REJECTs
+2 NEW PSOTMP,PSOSTS,PSODRNM,I,PSORX
+3 SET (PSOSTS,PSODRNM)=""
+4 FOR
SET PSOSTS=$ORDER(PSOSD(PSOSTS))
if PSOSTS=""
QUIT
Begin DoDot:1
+5 FOR
SET PSODRNM=$ORDER(PSOSD(PSOSTS,PSODRNM))
if PSODRNM=""
QUIT
Begin DoDot:2
+6 SET PSORX=+$GET(PSOSD(PSOSTS,PSODRNM))
+7 ; PSO*7*427 - add a new section for open TRICARE/CHAMPVA/RRR rejects after the 79/88 open rejects
+8 ; DUR/RTS
IF PSOSTS="ACTIVE"
IF $$FIND^PSOREJUT(PSORX,,,"79,88,943")
SET PSOTMP(" REJECT",PSODRNM)=PSOSTS
QUIT
+9 ; TRI/CVA
IF PSOSTS="ACTIVE"
IF $$TRIC^PSOREJP1(PSORX)
IF $$FIND^PSOREJUT(PSORX,,,,1)
SET PSOTMP(" REJECT2",PSODRNM)=PSOSTS
QUIT
+10 ; RRR
IF PSOSTS="ACTIVE"
IF '$$TRIC^PSOREJP1(PSORX)
IF $$FIND^PSOREJUT(PSORX,,,,,1)
SET PSOTMP(" REJECT2",PSODRNM)=PSOSTS
QUIT
+11 SET PSOTMP(PSOSTS,PSODRNM)=PSOSTS
End DoDot:2
End DoDot:1
+12 ;
+13 SET (PSOSTS,PSODRG)=""
SET (PSOCNT,PSOQFLG,IEN)=0
+14 KILL RN,DL
SET $PIECE(RN," ",12)=" "
SET $PIECE(DL," ",40)=" "
+15 FOR PSCNT=0:0
SET PSOSTS=$ORDER(PSOTMP(PSOSTS))
if PSOSTS=""
QUIT
Begin DoDot:1
+16 DO STA
+17 FOR PSOCT=0:0
SET PSODRG=$ORDER(PSOTMP(PSOSTS,PSODRG))
if PSODRG=""
QUIT
if PSOCNT>1000!PSOQFLG
QUIT
Begin DoDot:2
+18 SET PSOSTA=PSOTMP(PSOSTS,PSODRG)
+19 SET PSODATA=PSOSD(PSOSTA,PSODRG)
IF PSOSTA="ZNONVA"
DO NVA
QUIT
+20 SET PSOCNT=PSOCNT+1
IF PSOSTA="PENDING"
DO PEN
QUIT
+21 if '$DATA(^PSRX(+PSODATA,0))
SET PSOCNT=PSOCNT-1
if $DATA(^(0))
DO DISPL
End DoDot:2
End DoDot:1
+22 ;S (VALMCNT,PSOPF)=IEN
+23 ; bwf - 1/9/2014, PHARMACY INNOVATIONS. Adding display of remote rx's.
SHOWREM ;
+1 NEW REMSITE,RRXIEN,RRXDAT,RRXDNAME,RRXDNL,RRXQTY,RRXQTYL,RREFILLS,RRXDSUPP,RRXEXP,RRXISSDT,RRXISSDT1,RRXLFDT,RRXLFDT1,RRXDNSP,RRXQSP,REMSIEN,STAT,STATABBR,DLINE,DLEN
+2 NEW BSPACE,FSPACE,RSPACE,BDNAME,RRXISP,RXDUPP,PSORRLST
+3 ; SET UP PSORCNT
+4 SET PSORCNT=$GET(PSOCNT)
+5 IF '$DATA(^TMP("PSOPF",$JOB))
SET ^TMP("PSOPF",$JOB,1,0)="<No local prescriptions found.>"
SET IEN=$GET(IEN)+1
+6 ;S IEN=$G(IEN)+1,^TMP("PSOPF",$J,IEN,0)="-------------------------------------REMOTE-------------------------------------"
+7 SET REMSITE=0
FOR
SET REMSITE=$ORDER(^XTMP("PSORRX1",$JOB,PSODFN,REMSITE))
if 'REMSITE
QUIT
Begin DoDot:1
+8 IF REMSITE=$GET(DUZ(2))
QUIT
+9 ;S REMSIEN=$O(^DIC(4,"D",REMSITE,0))
+10 SET REMSIEN=$$FIND1^DIC(4,,"X",REMSITE,"D","I $P(^(0),U,11)=""N"",'$P($G(^(99)),U,4)")
if 'REMSIEN
QUIT
+11 SET STAT=0
FOR
SET STAT=$ORDER(^XTMP("PSORRX1",$JOB,PSODFN,REMSITE,STAT))
if STAT=""
QUIT
Begin DoDot:2
+12 SET STATABBR=$SELECT(STAT="ACTIVE":"A",STAT="HOLD":"H",STAT="PROVIDER HOLD":"PH",STAT="SUSPENDED":"S",STAT["DISCONTINUED":"DC",STAT="EXPIRED":"E",1:"")
+13 SET DLINE=$EXTRACT($$GET1^DIQ(4,REMSIEN,.01,"E"),1,30)_" ("_REMSITE_")"_$SELECT(STAT="ERR":"",1:" "_STAT)
SET DLEN=$LENGTH(DLINE)
+14 SET (FSPACE,RSPACE)=""
+15 SET BSPACE=IOM-$LENGTH(DLINE)
SET $PIECE(FSPACE,"-",(BSPACE\2))="-"
SET $PIECE(RSPACE,"-",(BSPACE\2)+$SELECT(BSPACE#2:1,1:0))="-"
+16 SET IEN=$GET(IEN)+1
SET ^TMP("PSOPF",$JOB,IEN,0)=FSPACE_$EXTRACT($$GET1^DIQ(4,REMSIEN,.01,"E"),1,30)_" ("_REMSITE_")"_$SELECT(STAT="ERR":"",1:" "_STAT)_RSPACE
+17 IF $DATA(^XTMP("PSORRX1",$JOB,PSODFN,REMSITE,"ERR"))
SET IEN=IEN+1
SET ^TMP("PSOPF",$JOB,IEN,0)=$GET(^XTMP("PSORRX1",$JOB,PSODFN,REMSITE,"ERR"))
+18 SET RRXDNAME=""
FOR
SET RRXDNAME=$ORDER(^XTMP("PSORRX1",$JOB,PSODFN,REMSITE,STAT,RRXDNAME))
if RRXDNAME=""
QUIT
Begin DoDot:3
+19 SET RRXDAT=$GET(^XTMP("PSORRX1",$JOB,PSODFN,REMSITE,STAT,RRXDNAME,0))
+20 SET BDNAME=$EXTRACT(RRXDNAME,1,35)
+21 SET RRXIEN=$PIECE(RRXDAT,U)
SET RRXDNL=$LENGTH(BDNAME)
SET RRXQTY=$PIECE(RRXDAT,U,2)
SET RRXQTYL=$LENGTH(RRXQTY)
SET RREFILLS=$PIECE(RRXDAT,U,3)
SET RRXDSUPP=$EXTRACT($PIECE(RRXDAT,U,4),2,4)
SET RRXEXP=$PIECE(RRXDAT,U,5)
+22 SET RRXISSDT=$PIECE($PIECE(RRXDAT,U,6),".")
SET RRXISSDT1=$EXTRACT(RRXISSDT,5,6)_"-"_$EXTRACT(RRXISSDT,7,8)
SET RRXLFDT=$PIECE($PIECE(RRXDAT,U,8),".")
SET RRXLFDT1=$EXTRACT(RRXLFDT,5,6)_"-"_$EXTRACT(RRXLFDT,7,8)
+23 SET IEN=$GET(IEN)+1
SET PSORCNT=PSORCNT+1
+24 SET (RRXDNSP,RRXISP)=""
+25 SET RRXQSP=" "_STATABBR
+26 ; length of Rx# varies
SET $PIECE(RRXISP," ",14-$LENGTH(RRXIEN))=" "
+27 if RRXDNL+RRXQTYL>39
SET BDNAME=$EXTRACT(BDNAME,1,$LENGTH(BDNAME)-(RRXDNL+RRXQTYL-39))
SET RRXDNL=$LENGTH(BDNAME)
+28 SET $PIECE(RRXDNSP," ",40-RRXQTYL-RRXDNL)=" "
+29 SET $PIECE(RRXQSP," ",4)=""
+30 IF $LENGTH(STATABBR)=2
SET RRXQSP=$EXTRACT(RRXQSP,1,$LENGTH(RRXQSP)-1)
+31 SET ^TMP("PSOPF",$JOB,IEN,0)=$JUSTIFY(PSORCNT,2)_$SELECT($LENGTH(PSORCNT)<3:" ",1:"")_RRXIEN_RRXISP_BDNAME_RRXDNSP_RRXQTY_RRXQSP_RRXISSDT1_" "
+32 SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_RRXLFDT1_$SELECT($LENGTH(RREFILLS)=1:" ",$LENGTH(RREFILLS=2):" ")_RREFILLS_$SELECT($LENGTH(RRXDSUPP=2):" ",$LENGTH(RXDUPP=1):" ",1:" ")_RRXDSUPP
+33 SET PSORRLST(PSORCNT)=IEN
+34 ; PSO*7*454 - Need to specify this differently for remote rx's.
+35 ; BWF 20161110 - LOOKING AT COUNT/DISPLAY
+36 ;S PSOLST(PSOCNT)="R52^"_RRXIEN_U_"REMOTE"_U_REMSITE
+37 SET PSOLST(PSORCNT)="R52^"_RRXIEN_U_"REMOTE"_U_REMSITE
End DoDot:3
End DoDot:2
End DoDot:1
+38 SET (VALMCNT,PSOPF)=IEN
SHOWX KILL DIRUT,DTOUT,DUOUT,DIROUT,PSODRG
+1 QUIT
+2 ;
DISPL SET IEN=IEN+1
NEW PSOID,PSOCMOP,STATLTH,ECME,TITRX,ORNUM,ERXIEN
+1 KILL PSOLNT,PSOQTL,PSOLSP
SET PSOLRX=$SELECT($GET(^PSRX(+PSODATA,"IB")):13,1:14)-$LENGTH($PIECE(^PSRX(+PSODATA,0),"^"))
SET $PIECE(PSOLNT," ",PSOLRX)=" "
SET PSODQL=$LENGTH($PIECE(PSODRG,"^"))+$LENGTH($PIECE(^PSRX(+PSODATA,0),"^",7))
+2 IF PSODQL<39
SET $PIECE(PSOQTL," ",(40-PSODQL))=" "
+3 IF '$TEST
SET $PIECE(PSOQTL," ",(52-$LENGTH($PIECE(^PSRX(+PSODATA,0),"^",7))))=" "
SET $PIECE(PSOLSP," ",(41-$LENGTH($PIECE(PSODRG,"^"))))=" "
+4 SET ECME=$$ECME^PSOBPSUT(+PSODATA)
IF ECME'=""
SET PSOLNT=$EXTRACT(PSOLNT,1,$LENGTH(PSOLNT)-1)
+5 SET TITRX=$$TITRX^PSOUTL(+PSODATA)
IF TITRX'=""
SET PSOLNT=$EXTRACT(PSOLNT,1,$LENGTH(PSOLNT)-1)
+6 ; PSO*7*508 - eRx check and addition of the '&' character for eRx prescriptions and split line due to xindex lentgh failure
+7 SET ORNUM=$$GET1^DIQ(52,+PSODATA,39.3,"I")
+8 IF ORNUM
SET ERXIEN=$$CHKERX^PSOERXU1(ORNUM)
IF $GET(ERXIEN)
SET PSOLNT=$EXTRACT(PSOLNT,1,$LENGTH(PSOLNT)-2)
+9 SET ^TMP("PSOPF",$JOB,IEN,0)=$JUSTIFY(PSOCNT,2)_$SELECT($LENGTH(PSOCNT)<3:" ",1:"")_$SELECT($GET(ERXIEN):"& ",1:"")_$PIECE(^PSRX(+PSODATA,0),"^")
+10 SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_$SELECT($GET(^PSRX(+PSODATA,"IB")):"$",1:"")_ECME_TITRX_PSOLNT_$PIECE(PSODRG,"^")_$SELECT(PSODQL<39:PSOQTL_$PIECE(^PSRX(+PSODATA,0),"^",7)_" ",1:$GET(PSOLSP))
+11 ; PSO*7*508 - end eRx modification - consider also checking the Rx index in 52.49 for further accuracy
+12 SET STA="A^N^R^H^N^S^^^^^^E^DC^^DP^DE^HP^P^"
+13 SET PSOCMOP=""
+14 IF $DATA(^PSDRUG("AQ",$PIECE(^PSRX(+PSODATA,0),"^",6)))
SET PSOCMOP=">"
+15 NEW X
SET X="PSXOPUTL"
XECUTE ^%ZOSF("TEST")
KILL X
IF $TEST
Begin DoDot:1
+16 NEW DA
SET DA=+PSODATA
DO ^PSXOPUTL
KILL DA
+17 IF $GET(PSXZ(PSXZ("L")))=0!($GET(PSXZ(PSXZ("L")))=2)
SET PSOCMOP="T"
+18 KILL PSXZ
End DoDot:1
+19 SET (STA,STATLTH)=$PIECE(STA,"^",$PIECE(PSODATA,"^",2)+1)
Begin DoDot:1
+20 IF $GET(^PSRX(+PSODATA,"DDSTA"))]""
SET (STATLTH,STA)="DD"
QUIT
+21 ;PAPI 441
IF $GET(^PSRX(+PSODATA,"PARK"))
IF STA="A"
SET STA="AP"
+22 SET (STATLTH,STA)=$SELECT($PIECE($GET(^PSRX(+PSODATA,7)),"^")=1:"DA",$PIECE($GET(^PSRX(+PSODATA,7)),"^")=2:"DF",1:STA)
End DoDot:1
+23 SET STAPRT=STA_PSOCMOP
SET STATLTH=$LENGTH(STAPRT)
+24 SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_STAPRT_$SELECT(STATLTH=0:" ",STATLTH=1:" ",STATLTH=2:" ",1:"")
+25 SET PSOID=$PIECE(^PSRX(+PSODATA,0),"^",13)
SET PSOLF=+$GET(^(3))
SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_$EXTRACT(PSOID,4,5)_"-"_$EXTRACT(PSOID,6,7)_" "
+26 NEW RFLZRO,PSOLRD
SET PSOLRD=$PIECE($GET(^PSRX(+PSODATA,2)),"^",13)
+27 FOR PSOX=0:0
SET PSOX=$ORDER(^PSRX(+PSODATA,1,PSOX))
if 'PSOX
QUIT
Begin DoDot:1
+28 SET RFLZRO=$GET(^PSRX(+PSODATA,1,PSOX,0))
+29 IF +RFLZRO=PSOLF
IF $PIECE(RFLZRO,"^",16)
SET PSOLF=PSOLF_"^R"
+30 if $PIECE(RFLZRO,"^",18)'=""
SET PSOLRD=$PIECE(RFLZRO,"^",18)
IF $PIECE(RFLZRO,"^",16)
SET PSOLRD=PSOLRD_"^R"
End DoDot:1
+31 KILL PSOX
+32 IF '$ORDER(^PSRX(+PSODATA,1,0))
IF $PIECE(^PSRX(+PSODATA,2),"^",15)
SET PSOLF=PSOLF_"^R"
SET PSOLRD=PSOLRD_"^R"
+33 SET PSOLF=$SELECT($GET(PSOLF):$EXTRACT(PSOLF,4,5),1:" ")_"-"_$SELECT($GET(PSOLF):$EXTRACT(PSOLF,6,7),1:" ")_$SELECT($PIECE(PSOLF,"^",2)="R":"R ",1:" ")
+34 SET PSOLRD=$SELECT($GET(PSOLRD):$EXTRACT(PSOLRD,4,5),1:" ")_"-"_$SELECT($GET(PSOLRD):$EXTRACT(PSOLRD,6,7),1:" ")_$SELECT($PIECE(PSOLRD,"^",2)="R":"R ",1:" ")
+35 SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_$SELECT($GET(PSORFG):PSOLRD,1:PSOLF)
+36 SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_$JUSTIFY($PIECE(PSODATA,"^",6),2)_" "_$JUSTIFY($PIECE(PSODATA,"^",8),3)
+37 ;K SPC S PSOIND=$G(^PSRX(+PSODATA,6.5)) S:PSOIND'="" IEN=IEN+1,$P(SPC," ",20)=" ",^TMP("PSOPF",$J,IEN,0)=SPC_"INDICATION: "_PSOIND
+38 ;recently dc'd rxs
+39 IF $PIECE($GET(^PSRX(+PSODATA,3)),"^",5)
Begin DoDot:1
+40 SET X2=$SELECT($PIECE(PSOPAR,"^",33):$PIECE(PSOPAR,"^",33),1:7)
SET X1=$PIECE(^PSRX(+PSODATA,3),"^",5)
DO C^%DTC
+41 IF DT<X
SET PSODCREV(IEN)=IEN
End DoDot:1
KILL X
+42 ;recently expired rxs
+43 IF $PIECE($GET(^PSRX(+PSODATA,2)),"^",6)<DT
IF '$PIECE($GET(^PSRX(+PSODATA,3)),"^",5)
Begin DoDot:1
+44 SET X2=$SELECT($PIECE(PSOPAR,"^",33):$PIECE(PSOPAR,"^",33),1:7)
SET X1=$PIECE(^PSRX(+PSODATA,2),"^",6)
DO C^%DTC
+45 IF DT<X
SET PSODCREV(IEN)=IEN
End DoDot:1
KILL X
+46 ;
+47 IF (PSODQL>38)!$$BADADDFL^PSOUTIL(+PSODATA)
Begin DoDot:1
+48 SET IEN=IEN+1
+49 IF PSODQL>38
SET ^TMP("PSOPF",$JOB,IEN,0)=PSOQTL_"Qty: "_$PIECE(^PSRX(+PSODATA,0),"^",7)
+50 IF $$BADADDFL^PSOUTIL(+PSODATA)
SET $EXTRACT(^TMP("PSOPF",$JOB,IEN,0),61)="*** Bad Address ***"
End DoDot:1
+51 ;
+52 KILL PSOLNT,PSOQTL,PSOLSP,PSOLRX,PSODQL
+53 SET PSOLST(PSOCNT)="52^"_+PSODATA_"^"_PSOSTA
+54 KILL PSODATA,PSOLF
SET PSOPF=IEN
+55 QUIT
+56 ;
STA NEW LABEL,LINE,POS
+1 SET LABEL=PSOSTS
SET IEN=IEN+1
+2 IF PSOSTS="ZNONVA"
SET LABEL="Non-VA MEDS (Not dispensed by VA)"
+3 IF PSOSTS=" REJECT"
SET LABEL="REFILL TOO SOON/DUR REJECTS (Third Party)"
+4 ;PSO*7*427 added new section
IF PSOSTS=" REJECT2"
SET LABEL="OTHER REJECTS PENDING RESOLUTION"
+5 SET POS=80-$LENGTH(LABEL)/2
SET $PIECE(LINE,"-",81)=""
SET $EXTRACT(LINE,POS+1,POS+$LENGTH(LABEL))=LABEL
+6 SET ^TMP("PSOPF",$JOB,IEN,0)=LINE
+7 QUIT
PENX SET PSOLST(PSOCNT)="52.41^"_$PIECE(PSODATA,"^",10)_"^"_PSOSTA
+1 ;K SPC S ENTRY=$P(PSODATA,"^",10),PSOIND=$P($G(^PS(52.41,ENTRY,4)),"^",2) S:PSOIND'="" IEN=IEN+1,$P(SPC," ",5)=" ",^TMP("PSOPF",$J,IEN,0)=SPC_"INDICATION: "_PSOIND
+2 KILL PSODATA,PSOLF,RN,PSOLSP,PSOQTL,PSOLNT
+3 QUIT
PEN ;
+1 NEW PSOQTL,PSOLNT,PSOLNTZ,PSOQTLX,PSCMOPF,SPACEZ,ORNUM,ERXIEN
+2 if '$DATA(^PS(52.41,$PIECE(PSODATA,"^",10),0))
QUIT
+3 SET PSCMOPF=0
IF $PIECE($GET(PSODATA),"^",11)
IF $DATA(^PSDRUG("AQ",$PIECE(PSODATA,"^",11)))
SET PSCMOPF=1
+4 ; PSO*7*508 - eRx check and addition of the '&' character for eRx prescriptions
+5 SET ORNUM=$$GET1^DIQ(52.41,$PIECE(PSODATA,U,10),.01,"I")
+6 IF ORNUM
SET ERXIEN=$$CHKERX^PSOERXU1(ORNUM)
+7 SET IEN=IEN+1
SET ^TMP("PSOPF",$JOB,IEN,0)=$JUSTIFY(PSOCNT,2)_$SELECT($LENGTH(PSOCNT)<3:" ",1:"")_$SELECT($GET(ERXIEN):"& ",1:"")_$PIECE(PSODRG,"^")
+8 ; PSO*7*508 - end eRx modification
+9 IF $PIECE($GET(^PS(52.41,+$PIECE(PSODATA,"^",10),0)),"^",23)=1
SET ^TMP("PSOPF",$JOB,IEN,"RV")=""
+10 SET PSOLNT=$LENGTH($PIECE(PSODRG,"^"))
SET PSOLNTZ=$LENGTH($PIECE(PSODATA,"^",8))
+11 ; PSO*7*508 - adjust PSOLNT if this is an eRx
+12 IF $GET(ERXIEN)
SET PSOLNT=PSOLNT+2
+13 SET $PIECE(PSOQTLX," ",(11-PSOLNTZ))=" "
+14 if PSOLNT<37
SET $PIECE(PSOQTL," ",(37-PSOLNT))=" "
+15 IF PSOLNT<38
Begin DoDot:1
+16 IF PSOLNT=37
SET PSOQTL=""
+17 IF $PIECE(^PS(52.41,$PIECE(PSODATA,"^",10),0),"^",3)="RF"
SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_$GET(PSOQTL)_" Refill Request Rx #: "_$PIECE(^PSRX($PIECE(^PS(52.41,$PIECE(PSODATA,"^",10),0),"^",19),0),"^")
QUIT
+18 SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_$GET(PSOQTL)_" "_"QTY: "_$PIECE(PSODATA,"^",8)_$GET(PSOQTLX)_" ISDT: "_$SELECT('$PIECE(PSODATA,"^",9):" ",1:...
... $EXTRACT($PIECE(PSODATA,"^",9),4,5)_"-"_$EXTRACT($PIECE(PSODATA,"^",9),6,7))_$SELECT($GET(PSCMOPF):"> ",1:" ")
+19 SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_"REF: "_$SELECT($LENGTH($PIECE(PSODATA,"^",6))>1:"",1:" ")_$PIECE(PSODATA,"^",6)
End DoDot:1
GOTO PENX
+20 SET IEN=IEN+1
SET $PIECE(SPACEZ," ",42)=" "
+21 IF $PIECE(^PS(52.41,$PIECE(PSODATA,"^",10),0),"^",3)="RF"
SET ^TMP("PSOPF",$JOB,IEN,0)=SPACEZ_"Refill Request Rx #: "_$PIECE(^PSRX($PIECE(^PS(52.41,$PIECE(PSODATA,"^",10),0),"^",19),0),"^")
GOTO PENX
+22 SET ^TMP("PSOPF",$JOB,IEN,0)=SPACEZ_"QTY: "_$PIECE(PSODATA,"^",8)_$GET(PSOQTLX)_" ISDT: "_...
... $SELECT('$PIECE(PSODATA,"^",9):" ",1:$EXTRACT($PIECE(PSODATA,"^",9),4,5)_"-"_$EXTRACT($PIECE(PSODATA,"^",9),6,7))_$SELECT($GET(PSCMOPF):"> ",1:" ")_"REF: "_$SELECT($LENGTH($PIECE(PSODATA,"^",6))>1:"",1:" ")
+23 SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_$PIECE(PSODATA,"^",6)
+24 GOTO PENX
+25 ;
NVA ; Setting the Non-VA Meds on the Medication Profile Screen (ListMan) *modified listman to a new look to accomodate complex orders
+1 ;drug name
SET IEN=IEN+1
SET ^TMP("PSOPF",$JOB,IEN,0)=" "_$PIECE(PSODRG,"^")_" "
+2 if ($LENGTH(^TMP("PSOPF",$JOB,IEN,0))+$LENGTH($PIECE(PSODATA,"^",6))>80)
SET IEN=IEN+1
SET ^TMP("PSOPF",$JOB,IEN,0)=" "
+3 ;dosage
SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_$PIECE(PSODATA,"^",6)_" "
+4 if ($LENGTH(^TMP("PSOPF",$JOB,IEN,0))+$LENGTH($PIECE(PSODATA,"^",8))>80)
SET IEN=IEN+1
SET ^TMP("PSOPF",$JOB,IEN,0)=" "
+5 ;sched
SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_$PIECE(PSODATA,"^",8)_" "
+6 ;dura opt.
IF $PIECE(PSODATA,"^",12)]""
Begin DoDot:1
+7 if ($LENGTH(^TMP("PSOPF",$JOB,IEN,0))+$LENGTH($PIECE(PSODATA,"^",12))>80)
SET IEN=IEN+1
SET ^TMP("PSOPF",$JOB,IEN,0)=" "
+8 ;dura
SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_"FOR "_$PIECE(PSODATA,"^",12)_" "
End DoDot:1
+9 ;conj opt. if present quit so next complex drug on new line
IF $PIECE(PSODATA,"^",13)]""
Begin DoDot:1
+10 if ($LENGTH(^TMP("PSOPF",$JOB,IEN,0))+$LENGTH($PIECE(PSODATA,"^",13))>78)
SET IEN=IEN+1
SET ^TMP("PSOPF",$JOB,IEN,0)=" "
+11 ;conj
SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_"-"_$PIECE(PSODATA,"^",13)_"-"
End DoDot:1
QUIT
+12 ;print date documented info @ col 62
+13 if ($LENGTH(^TMP("PSOPF",$JOB,IEN,0)))>62
SET IEN=IEN+1
SET ^TMP("PSOPF",$JOB,IEN,0)=" "
+14 ;space fill to 62
IF $LENGTH(^TMP("PSOPF",$JOB,IEN,0))<62
FOR
SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_" "
if $LENGTH(^TMP("PSOPF",$JOB,IEN,0))>61
QUIT
+15 SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_"Date Doc: "_$EXTRACT($PIECE(PSODATA,"^",9),4,5)_"/"_$EXTRACT($PIECE(PSODATA,"^",9),6,7)_"/"_$EXTRACT($PIECE(PSODATA,"^",9),2,3)
+16 QUIT
