Routine: PSOORUT1

PSOORUT1 ;BIR/SAB - Utility routine for oerr interface ;26-Feb-2013 11:13;DU

 ;;7.0;OUTPATIENT PHARMACY;**1,14,30,46,132,1005,1006,148,233,274,225,305,289,1015,1016**;DEC 1997;Build 74

 ;External reference to ^PSDRUG supported by DBIA 221

 ;External reference to ^PSXOPUTL supported by DBIA 2203

 ;called from HD^PSOORUTL

 ; Modified - IHS/CIA/PLS - 01/15/04 - SHOW+5

 ;            IHS/MSC/PLS - 10/11/07 - STA+1,DISPL

 ; Modified - IHS/MSC/MGH - 02/26/13 - SHOW+4,18,21

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,,$$RXFLDT^PSOBPSUT(DA),$S('$O(^PSRX(DA,1,0)):"OF",1:"RF"))

 G EXIT^PSOORUTL

ACT1 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

SUS ;

 I $P($G(^PSRX(+$G(FILLER),"STA")),"^")=5 N PSOMSORR,PLACERXX D EN^PSOHLSN1(+$G(FILLER),"SC","ZS","")

BLD ;builds med profile for Listman

 K ^TMP("PSOPF",$J),PSOLST S:$G(PSOOPT)'=3 PSOOPT=0 I '$G(PSOSD) 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

 ;-----------------------------------------------------------------

SHOW ;

 ; - ePharmacy modification to create a section for Rx with REJECTs

 N PSOTMP,PSOSTS,PSODRNM,I,PSORX,CHECK

 S (PSOSTS,PSODRNM)=""

 S CHECK=0

 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))

 . . I PSOSTS="ACTIVE",$$FIND^PSOREJUT(PSORX,,,"79,88") D  Q

 . . . S PSOTMP(" REJECT",PSODRNM)=PSOSTS

 . . 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" S CHECK=1 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

 I CHECK=0 S PSOSTS="ZNONVA" D STA

 D FMTLINES^APSQSHOW($NA(^TMP("PSOPF",$J)),.IEN,1)   ; IHS/CIA/PLS - 01/15/04 - Collect Outside Rxs; IHS/MSC/PLS - 11/16/07 Added new flag

 S (VALMCNT,PSOPF)=IEN

SHOWX K DIRUT,DTOUT,DUOUT,DIROUT,PSODRG

DISPL S IEN=IEN+1 N PSOID,PSOCMOP,STATLTH,ECME

 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)

 ;IHS/MSC/PLS - 10/11/07

 ;S ^TMP("PSOPF",$J,IEN,0)=$J(PSOCNT,2)_$S($L(PSOCNT)<3:" ",1:"")_$P(^PSRX(+PSODATA,0),"^")_$S($G(^PSRX(+PSODATA,"IB")):"$",1:"")_ECME_PSOLNT_$P(PSODRG,"^")_$S(PSODQL<39:PSOQTL_$P(^PSRX(+PSODATA,0),"^",7)_" ",1:$G(PSOLSP))

 S ^TMP("PSOPF",$J,IEN,0)=$S(PSOSTA="ACTIVE OTHER PHARMACY":"  ",1:$J(PSOCNT,2))_$S($L(PSOCNT)<3:" ",1:"")_$P(^PSRX(+PSODATA,0),"^")_$S($G(^PSRX(+PSODATA,"IB")):"$",1:"")_ECME_PSOLNT_$P(PSODRG,"^")

 S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$S(PSODQL<39:PSOQTL_$P(^PSRX(+PSODATA,0),"^",7)_" ",1:$G(PSOLSP))

 S STA="A^N^R^H^N^S^^^^^^E^DC^^DC^DE^H^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

 N PSOBADR

 S PSOBADR=$O(^PSRX(+PSODATA,"L",9999),-1)

 I PSOBADR'="" S PSOBADR=$G(^PSRX(+PSODATA,"L",PSOBADR,0)) I PSOBADR["(BAD ADDRESS)" S PSOBADR="B"

 I PSOBADR'="B" S PSOBADR=""

 S STAPRT=$P(STA,"^",$P(PSODATA,"^",2)+1)_PSOCMOP_PSOBADR

 S 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)

 I PSODQL>38 S IEN=IEN+1 S ^TMP("PSOPF",$J,IEN,0)=PSOQTL_"Qty: "_$P(^PSRX(+PSODATA,0),"^",7)

 K PSOLNT,PSOQTL,PSOLSP,PSOLRX,PSODQL

 S PSOLST(PSOCNT)="52^"_+PSODATA_"^"_PSOSTA

 K PSODATA,PSOLF S PSOPF=IEN

STA N LABEL,LINE,POS

 S LABEL=PSOSTS,IEN=IEN+1

 ;IHS/MSC/PLS - 10/11/07

 ;I PSOSTS="ZNONVA" S LABEL="Non-VA MEDS (Not dispensed by VA)"

 I PSOSTS="ZNONVA" S LABEL="Outside Medications"

 I PSOSTS=" REJECT" S LABEL="REFILL TOO SOON/DUR REJECTS (Third Party)"

 S POS=80-$L(LABEL)/2,$P(LINE,"-",81)="",$E(LINE,POS+1,POS+$L(LABEL))=LABEL

 S ^TMP("PSOPF",$J,IEN,0)=LINE

PENX S PSOLST(PSOCNT)="52.41^"_$P(PSODATA,"^",10)_"^"_PSOSTA

 K PSODATA,PSOLF,RN,PSOLSP,PSOQTL,PSOLNT

PEN ;

 N PSOQTL,PSOLNT,PSOLNTZ,PSOQTLX,PSCMOPF,SPACEZ

 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

 S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=$J(PSOCNT,2)_$S($L(PSOCNT)<3:" ",1:"")_$P(PSODRG,"^")

 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))

 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)

 S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)="  "_$P(PSODRG,"^")_" "

 I ($L(^TMP("PSOPF",$J,IEN,0))+$L($P(PSODATA,"^",6))>70) S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)="    "

 S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",6)_" "

 I ($L(^TMP("PSOPF",$J,IEN,0))+$L($P(PSODATA,"^",8))>70) S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)="    "

 S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",8)

 I ($L(^TMP("PSOPF",$J,IEN,0))+20)>70 D  Q

 . S IEN=IEN+1,$P(^TMP("PSOPF",$J,IEN,0)," ",51)="Date Documented: "_$E($P(PSODATA,"^",9),4,5)_"/"_$E($P(PSODATA,"^",9),6,7)_"/"_$E($P(PSODATA,"^",9),2,3)

 F I=0:0 S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_" " Q:$L(^TMP("PSOPF",$J,IEN,0))>49

 S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_"Date Documented: "_$E($P(PSODATA,"^",9),4,5)_"/"_$E($P(PSODATA,"^",9),6,7)_"/"_$E($P(PSODATA,"^",9),2,3)

PSOORUT1  ;BIR/SAB - Utility routine for oerr interface ;26-Feb-2013 11:13;DU

 +1       ;;7.0;OUTPATIENT PHARMACY;**1,14,30,46,132,1005,1006,148,233,274,225,305,289,1015,1016**;DEC 1997;Build 74

 +2       ;External reference to ^PSDRUG supported by DBIA 221

 +3       ;External reference to ^PSXOPUTL supported by DBIA 2203

 +4       ;called from HD^PSOORUTL

 +5       ; Modified - IHS/CIA/PLS - 01/15/04 - SHOW+5

 +6       ;            IHS/MSC/PLS - 10/11/07 - STA+1,DISPL

 +7       ; Modified - IHS/MSC/MGH - 02/26/13 - SHOW+4,18,21

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,,$$RXFLDT^PSOBPSUT(DA),$SELECT('$ORDER(^PSRX(DA,1,0)):"OF",1:"RF"))

               End DoDot:1

               GOTO EXIT^PSOORUTL

 +24       GOTO EXIT^PSOORUTL

ACT1       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 ^TMP("PSOPF",$JOB),PSOLST

           IF $GET(PSOOPT)'=3

               SET PSOOPT=0

           IF '$GET(PSOSD)

               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,CHECK

 +3        SET (PSOSTS,PSODRNM)=""

 +4        SET CHECK=0

 +5        FOR

               SET PSOSTS=$ORDER(PSOSD(PSOSTS))

               IF PSOSTS=""

                   QUIT

               Begin DoDot:1

 +6                FOR

                       SET PSODRNM=$ORDER(PSOSD(PSOSTS,PSODRNM))

                       IF PSODRNM=""

                           QUIT

                       Begin DoDot:2

 +7                        SET PSORX=+$GET(PSOSD(PSOSTS,PSODRNM))

 +8                        IF PSOSTS="ACTIVE"

                               IF $$FIND^PSOREJUT(PSORX,,,"79,88")

                                   Begin DoDot:3

 +9                                    SET PSOTMP(" REJECT",PSODRNM)=PSOSTS

                                   End DoDot:3

                                   QUIT

 +10                       SET PSOTMP(PSOSTS,PSODRNM)=PSOSTS

                       End DoDot:2

               End DoDot:1

 +11      ;

 +12       SET (PSOSTS,PSODRG)=""

           SET (PSOCNT,PSOQFLG,IEN)=0

 +13       KILL RN,DL

           SET $PIECE(RN," ",12)=" "

           SET $PIECE(DL," ",40)=" "

 +14       FOR PSCNT=0:0

               SET PSOSTS=$ORDER(PSOTMP(PSOSTS))

               IF PSOSTS=""

                   QUIT

               Begin DoDot:1

 +15               DO STA

 +16               FOR PSOCT=0:0

                       SET PSODRG=$ORDER(PSOTMP(PSOSTS,PSODRG))

                       IF PSODRG=""

                           QUIT

                       IF PSOCNT>1000!PSOQFLG

                           QUIT

                       Begin DoDot:2

 +17                       SET PSOSTA=PSOTMP(PSOSTS,PSODRG)

 +18                       SET PSODATA=PSOSD(PSOSTA,PSODRG)

                           IF PSOSTA="ZNONVA"

                               SET CHECK=1

                               DO NVA

                               QUIT

 +19                       SET PSOCNT=PSOCNT+1

                           IF PSOSTA="PENDING"

                               DO PEN

                               QUIT

 +20                       IF '$DATA(^PSRX(+PSODATA,0))

                               SET PSOCNT=PSOCNT-1

                           IF $DATA(^(0))

                               DO DISPL

                       End DoDot:2

               End DoDot:1

 +21       IF CHECK=0

               SET PSOSTS="ZNONVA"

               DO STA

 +22      ; IHS/CIA/PLS - 01/15/04 - Collect Outside Rxs; IHS/MSC/PLS - 11/16/07 Added new flag

           DO FMTLINES^APSQSHOW($NAME(^TMP("PSOPF",$JOB)),.IEN,1)

 +23       SET (VALMCNT,PSOPF)=IEN

SHOWX      KILL DIRUT,DTOUT,DUOUT,DIROUT,PSODRG

 +1        QUIT

 +2       ;

DISPL      SET IEN=IEN+1

           NEW PSOID,PSOCMOP,STATLTH,ECME

 +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       ;IHS/MSC/PLS - 10/11/07

 +6       ;S ^TMP("PSOPF",$J,IEN,0)=$J(PSOCNT,2)_$S($L(PSOCNT)<3:" ",1:"")_$P(^PSRX(+PSODATA,0),"^")_$S($G(^PSRX(+PSODATA,"IB")):"$",1:"")_ECME_PSOLNT_$P(PSODRG,"^")_$S(PSODQL<39:PSOQTL_$P(^PSRX(+PSODATA,0),"^",7)_" ",1:$G(PSOLSP))

 +7        SET ^TMP("PSOPF",$JOB,IEN,0)=$SELECT(PSOSTA="ACTIVE OTHER PHARMACY":"  ",1:$JUSTIFY(PSOCNT,2))_$SELECT($LENGTH(PSOCNT)<3:" ",1:"")_$PIECE(^PSRX(+PSODATA,0),"^")_$SELECT($GET(^PSRX(+PSODATA,"IB")):"$",1:"")_ECME_PSOLNT_$PIECE(PSODRG,"^")

 +8        SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_$SELECT(PSODQL<39:PSOQTL_$PIECE(^PSRX(+PSODATA,0),"^",7)_" ",1:$GET(PSOLSP))

 +9       ;

 +10       SET STA="A^N^R^H^N^S^^^^^^E^DC^^DC^DE^H^P^"

 +11       SET PSOCMOP=""

 +12       IF $DATA(^PSDRUG("AQ",$PIECE(^PSRX(+PSODATA,0),"^",6)))

               SET PSOCMOP=">"

 +13       NEW X

           SET X="PSXOPUTL"

           XECUTE ^%ZOSF("TEST")

           KILL X

           IF $TEST

               Begin DoDot:1

 +14               NEW DA

                   SET DA=+PSODATA

                   DO ^PSXOPUTL

                   KILL DA

 +15               IF $GET(PSXZ(PSXZ("L")))=0!($GET(PSXZ(PSXZ("L")))=2)

                       SET PSOCMOP="T"

 +16               KILL PSXZ

               End DoDot:1

 +17       NEW PSOBADR

 +18       SET PSOBADR=$ORDER(^PSRX(+PSODATA,"L",9999),-1)

 +19       IF PSOBADR'=""

               SET PSOBADR=$GET(^PSRX(+PSODATA,"L",PSOBADR,0))

               IF PSOBADR["(BAD ADDRESS)"

                   SET PSOBADR="B"

 +20       IF PSOBADR'="B"

               SET PSOBADR=""

 +21       SET STAPRT=$PIECE(STA,"^",$PIECE(PSODATA,"^",2)+1)_PSOCMOP_PSOBADR

 +22       SET STATLTH=$LENGTH(STAPRT)

 +23       SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_STAPRT_$SELECT(STATLTH=0:"   ",STATLTH=1:"  ",STATLTH=2:" ",1:"")

 +24       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)_" "

 +25       NEW RFLZRO,PSOLRD

           SET PSOLRD=$PIECE($GET(^PSRX(+PSODATA,2)),"^",13)

 +26       FOR PSOX=0:0

               SET PSOX=$ORDER(^PSRX(+PSODATA,1,PSOX))

               IF 'PSOX

                   QUIT

               Begin DoDot:1

 +27               SET RFLZRO=$GET(^PSRX(+PSODATA,1,PSOX,0))

 +28               IF +RFLZRO=PSOLF

                       IF $PIECE(RFLZRO,"^",16)

                           SET PSOLF=PSOLF_"^R"

 +29               IF $PIECE(RFLZRO,"^",18)'=""

                       SET PSOLRD=$PIECE(RFLZRO,"^",18)

                   IF $PIECE(RFLZRO,"^",16)

                       SET PSOLRD=PSOLRD_"^R"

               End DoDot:1

 +30       KILL PSOX

 +31       IF '$ORDER(^PSRX(+PSODATA,1,0))

               IF $PIECE(^PSRX(+PSODATA,2),"^",15)

                   SET PSOLF=PSOLF_"^R"

                   SET PSOLRD=PSOLRD_"^R"

 +32       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:"  ")

 +33       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:"  ")

 +34       SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_$SELECT($GET(PSORFG):PSOLRD,1:PSOLF)

 +35       SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_$JUSTIFY($PIECE(PSODATA,"^",6),2)_" "_$JUSTIFY($PIECE(PSODATA,"^",8),3)

 +36       IF PSODQL>38

               SET IEN=IEN+1

               SET ^TMP("PSOPF",$JOB,IEN,0)=PSOQTL_"Qty: "_$PIECE(^PSRX(+PSODATA,0),"^",7)

 +37       KILL PSOLNT,PSOQTL,PSOLSP,PSOLRX,PSODQL

 +38       SET PSOLST(PSOCNT)="52^"_+PSODATA_"^"_PSOSTA

 +39       KILL PSODATA,PSOLF

           SET PSOPF=IEN

 +40       QUIT

 +41      ;

STA        NEW LABEL,LINE,POS

 +1        SET LABEL=PSOSTS

           SET IEN=IEN+1

 +2       ;IHS/MSC/PLS - 10/11/07

 +3       ;I PSOSTS="ZNONVA" S LABEL="Non-VA MEDS (Not dispensed by VA)"

 +4        IF PSOSTS="ZNONVA"

               SET LABEL="Outside Medications"

 +5        IF PSOSTS=" REJECT"

               SET LABEL="REFILL TOO SOON/DUR REJECTS (Third Party)"

 +6        SET POS=80-$LENGTH(LABEL)/2

           SET $PIECE(LINE,"-",81)=""

           SET $EXTRACT(LINE,POS+1,POS+$LENGTH(LABEL))=LABEL

 +7        SET ^TMP("PSOPF",$JOB,IEN,0)=LINE

 +8        QUIT

PENX       SET PSOLST(PSOCNT)="52.41^"_$PIECE(PSODATA,"^",10)_"^"_PSOSTA

 +1        KILL PSODATA,PSOLF,RN,PSOLSP,PSOQTL,PSOLNT

 +2        QUIT

PEN       ;

 +1        NEW PSOQTL,PSOLNT,PSOLNTZ,PSOQTLX,PSCMOPF,SPACEZ

 +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        SET IEN=IEN+1

           SET ^TMP("PSOPF",$JOB,IEN,0)=$JUSTIFY(PSOCNT,2)_$SELECT($LENGTH(PSOCNT)<3:" ",1:"")_$PIECE(PSODRG,"^")

 +5        IF $PIECE($GET(^PS(52.41,+$PIECE(PSODATA,"^",10),0)),"^",23)=1

               SET ^TMP("PSOPF",$JOB,IEN,"RV")=""

 +6        SET PSOLNT=$LENGTH($PIECE(PSODRG,"^"))

           SET PSOLNTZ=$LENGTH($PIECE(PSODATA,"^",8))

 +7        SET $PIECE(PSOQTLX," ",(11-PSOLNTZ))=" "

 +8        IF PSOLNT<37

               SET $PIECE(PSOQTL," ",(37-PSOLNT))=" "

 +9        IF PSOLNT<38

               Begin DoDot:1

 +10               IF PSOLNT=37

                       SET PSOQTL=""

 +11               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

 +12              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:"  ")

 +13               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

 +14       SET IEN=IEN+1

           SET $PIECE(SPACEZ," ",42)=" "

 +15       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

 +16      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:" ")

 +17       SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_$PIECE(PSODATA,"^",6)

 +18       GOTO PENX

 +19      ;

NVA       ; Setting the Non-VA Meds on the Medication Profile Screen (ListMan)

 +1        SET IEN=IEN+1

           SET ^TMP("PSOPF",$JOB,IEN,0)="  "_$PIECE(PSODRG,"^")_" "

 +2        IF ($LENGTH(^TMP("PSOPF",$JOB,IEN,0))+$LENGTH($PIECE(PSODATA,"^",6))>70)

               SET IEN=IEN+1

               SET ^TMP("PSOPF",$JOB,IEN,0)="    "

 +3        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))>70)

               SET IEN=IEN+1

               SET ^TMP("PSOPF",$JOB,IEN,0)="    "

 +5        SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_$PIECE(PSODATA,"^",8)

 +6        IF ($LENGTH(^TMP("PSOPF",$JOB,IEN,0))+20)>70

               Begin DoDot:1

 +7                SET IEN=IEN+1

                   SET $PIECE(^TMP("PSOPF",$JOB,IEN,0)," ",51)="Date Documented: "_$EXTRACT($PIECE(PSODATA,"^",9),4,5)_"/"_$EXTRACT($PIECE(PSODATA,"^",9),6,7)_"/"_$EXTRACT($PIECE(PSODATA,"^",9),2,3)

               End DoDot:1

               QUIT

 +8        FOR I=0:0

               SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_" "

               IF $LENGTH(^TMP("PSOPF",$JOB,IEN,0))>49

                   QUIT

 +9        SET ^TMP("PSOPF",$JOB,IEN,0)=^TMP("PSOPF",$JOB,IEN,0)_"Date Documented: "_$EXTRACT($PIECE(PSODATA,"^",9),4,5)_"/"_$EXTRACT($PIECE(PSODATA,"^",9),6,7)_"/"_$EXTRACT($PIECE(PSODATA,"^",9),2,3)

 +10       QUIT

PSOORUT1.m