PSORXVW ;BIR/SAB - ListMan View of a Prescription ;Dec 13, 2021@09:48
;;7.0;OUTPATIENT PHARMACY;**14,35,46,96,103,88,117,131,146,156,185,210,148,233,260,264,281,359,385,400,391,313,427,504,622,441,651,697,753**;DEC 1997;Build 53
; Reference to ^PS(55 in ICR #2228
; Reference to ^PS(50.7 in ICR #2223
; Reference to ^PSDRUG( in ICR #221
; Reference to ^VA(200 in ICR #10060
; Reference to ^SC in ICR #10040
; Reference to ^DPT in ICR #10035
; Reference to ^PS(50.606 in ICR #2174
; Reference to GMRADPT in ICR #10099
; Reference to $$BADADR^DGUTL3 in ICR #4080
; Reference to $$POSTSHRT^WVRPCOR in ICR #6174
;
S PS="VIEW"
A1 ; - Prescription prompt
S DIR(0)="FAO^1:30",DIR("A")=PS_" PRESCRIPTION: ",(DIR("?"),DIR("??"))="^D HLP^PSORXVW1"
W ! D ^DIR I X=""!$D(DIRUT) K:$G(PS)="VIEW" DA K PS G KILL
S X=$$UP^XLFSTR(X),QUIT=0
I $E(X,1,2)'="E." S (DA,PSOVDA)=+$$LKP^PSORXVW1(X) I DA<0 G A1
I $E(X,1,2)="E." D I QUIT G A1 ; esg 12/7/10 - ECME# lookup - PSO*7*359
.S (DA,PSOVDA)=+$$RXNUM^PSOBPSU2($E(X,3,$L(X))) I DA<0 W " ??",$C(7) S QUIT=1
;
; pso*7*385 - esg - Routine BPSRVX is calling this routine here at entry point DP in order to capture the
; scratch global data for the View ECME Rx option. Special variable BPSVRX=1 in this case.
DP ; DBIA #4711 entry point from ECME
;
S (PSODFN,DFN)=+$P(^PSRX(DA,0),"^",2) S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
D ICN^PSODPT(PSODFN)
K ^TMP("PSOHDR",$J) D ^VADPT,ADD^VADPT
S ^TMP("PSOHDR",$J,1,0)=VADM(1)
N PSOBADR,PSOTEMP
S PSOBADR=$$BADADR^DGUTL3(DFN) I PSOBADR S PSOTEMP=$$CHKTEMP^PSOBAI(DFN) D
.S ^TMP("PSOHDR",$J,1,0)=^TMP("PSOHDR",$J,1,0)_" ** BAD ADDRESS INDICATED-("_$S(PSOBADR=1:"UNDELIVERABLE",PSOBADR=2:"HOMELESS",1:"OTHER")_")"_$S(PSOTEMP:" Active Temporary Address",1:"")
S ^TMP("PSOHDR",$J,2,0)=$P(VADM(2),"^",2)
S ^TMP("PSOHDR",$J,3,0)=$P(VADM(3),"^",2),^TMP("PSOHDR",$J,4,0)=VADM(4),^TMP("PSOHDR",$J,5,0)=$P(VADM(5),"^",2)
S POERR=1 D RE^PSODEM K PSOERR
S ^TMP("PSOHDR",$J,6,0)=$S(+$P(WT,"^",8):$P(WT,"^",9)_" ("_$P(WT,"^")_")",1:"_______ (______)")
S ^TMP("PSOHDR",$J,7,0)=$S($P(HT,"^",8):$P(HT,"^",9)_" ("_$P(HT,"^")_")",1:"_______ (______)") K VM,WT,HT S PSOHD=7
S GMRA="0^0^111" D EN1^GMRADPT S ^TMP("PSOHDR",$J,8,0)=+$G(GMRAL)
S ^TMP("PSOHDR",$J,14,0)=$$POSTSHRT^WVRPCOR(PSODFN)
D DEM^VADPT I +VADM(6) D
.S SSN=$P(^DPT(PSODFN,0),"^",9) W !,$C(7),?10,$P(^DPT(PSODFN,0),"^")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_") DIED "_$P(VADM(6),"^",2),!
.W "All Active Medications will be Autocanceled!",! H 2 S PSODEATH=1
.S ACOM="Date of Death "_$P(VADM(6),"^",2)_".",ZTRTN="CAN^PSOCAN3",ZTDESC="Outpatient Pharmacy Autocancel Due to Death of Patient",ZTSAVE("ACOM")="",ZTSAVE("PSODFN")="",ZTSAVE("PSODEATH")=""
.S ZTIO="",PSOCLC=DUZ,ZTSAVE("PSOCLC")="",ZTDTH=$H D ^%ZTLOAD K ACOM,ZTSK,PSODEATH
K ^TMP("PSOAL",$J),PCOMX,PDA,PHI,PRC,ACOM,ANS
S (DA,RXN)=PSOVDA K PSOVDA S RX0=^PSRX(RXN,0),RX2=$G(^(2)),RX3=$G(^(3)),ST=+$G(^("STA")),RXOR=$G(^("OR1"))
I 'RXOR,$P(^PSDRUG($P(RX0,"^",6),2),"^") S $P(^PSRX(RXN,"OR1"),"^")=$P(^PSDRUG($P(RX0,"^",6),2),"^"),RXOR=$P(^PSDRUG($P(RX0,"^",6),2),"^")
S IEN=0,$P(RN," ",12)=" "
N APPND,ECME,TITR,ERXIEN
S APPND=$S($G(^PSRX(RXN,"IB")):"$",1:"")
S ECME=$$ECME^PSOBPSUT(RXN) ; Returns "" (non-ECME), or "e" (ECME)
S TITR=$$TITRX^PSOUTL(RXN) ; Returns "" (non-Titration), "m" (Maintenance) or "t" (titration)
S APPND=APPND_ECME_TITR
I ECME'="" S APPND=APPND_" (ECME#: "_$$ECMENUM^PSOBPSU2(RXN)_")"
I TITR'="" S APPND=APPND_" ("_$S(TITR="t":"Titration",1:"Maintenance")_")"
;PSO*7.0*697: add eRx indicator and break first line up for readability
S ERXIEN=$$CHKERX^PSOERXU1($P(RXOR,"^",2))
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$S($P($G(^PSRX(RXN,"TPB")),"^"):" TPB Rx #: ",1:" Rx #: ")_$S(ERXIEN:"& ",1:"")
S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_$P(RX0,"^")_APPND_$E(RN,$L($P(RX0,"^")_APPND)+1,12)
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Orderable Item: "_$S($D(^PS(50.7,$P(+RXOR,"^"),0)):$P(^PS(50.7,$P(+RXOR,"^"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^"),1:"No Pharmacy Orderable Item")
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$S($D(^PSDRUG("AQ",$P(RX0,"^",6))):" CMOP ",1:" ")_"Drug: "_$P(^PSDRUG($P(RX0,"^",6),0),"^")
S:$G(^PSRX(RXN,"TN"))]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Trade Name: "_$G(^PSRX(RXN,"TN"))
; Always display the NDC# - PSO*7*427
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" NDC: "_$$GETNDC^PSONDCUT(RXN,0)
D DOSE^PSORXVW1
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Patient Instructions:" I $O(^PSRX(RXN,"INS1",0)) D
. F I=0:0 S I=$O(^PSRX(RXN,"INS1",I)) Q:'I D
.. S MIG=^PSRX(RXN,"INS1",I,0)
.. D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21)
K MIG,SG
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Indications: "_$P($G(^PSRX(RXN,"IND")),"^") ;*441-IND
I $P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Other Pat. Instruc: "_$S($G(^PSRX(RXN,"INSS"))]"":^PSRX(RXN,"INSS"),1:"") D
. S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Other Indications: "_$P($G(^PSRX(RXN,"IND")),"^",3) ;*441-IND
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" SIG:"
I '$P($G(^PSRX(RXN,"SIG")),"^",2) D G PTST
. S X=$P($G(^PSRX(RXN,"SIG")),"^") D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250)
. D WORDWRAP^PSOUTLA2(SIG,.IEN,$NA(^TMP("PSOAL",$J)),21)
S SIGOK=1
F I=0:0 S I=$O(^PSRX(RXN,"SIG1",I)) Q:'I D
. S MIG=^PSRX(RXN,"SIG1",I,0)
. D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21)
S SIGOK=1 K MIG,SG
PTST S $P(RN," ",25)=" ",PTST=$S($G(^PS(53,+$P(RX0,"^",3),0))]"":$P($G(^PS(53,+$P(RX0,"^",3),0)),"^"),1:""),IEN=IEN+1
S ^TMP("PSOAL",$J,IEN,0)=" Patient Status: "_PTST_$E(RN,$L(PTST)+1,25)
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Issue Date: "_$E($P(RX0,"^",13),4,5)_"/"_$E($P(RX0,"^",13),6,7)_"/"_$E($P(RX0,"^",13),2,3)
S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" Fill Date: "_$E($P(RX2,"^",2),4,5)_"/"_$E($P(RX2,"^",2),6,7)_"/"_$E($P(RX2,"^",2),2,3)
S ROU=$S($P(RX0,"^",11)="W":"Window",$P(RX0,"^",11)="P":"Parked",1:"Mail") ;441 PAPI
S REFL=$P(RX0,"^",9),I=0 F S I=$O(^PSRX(RXN,1,I)) Q:'I S REFL=REFL-1,ROU=$S($P(^PSRX(RXN,1,I,0),"^",2)="W":"Window",$P(^PSRX(RXN,1,I,0),"^",2)="P":"Parked",1:"Mail") ;441 PAPI
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Last Fill Date: "_$E($P(RX3,"^"),4,5)_"/"_$E($P(RX3,"^"),6,7)_"/"_$E($P(RX3,"^"),2,3)
D CMOP^PSOORNE3 S DA=RXN
S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" ("_ROU_$S($G(PSOCMOP)]"":", "_PSOCMOP,1:"")_")" K ROU,PSOCMOP
S IEN=IEN+1 I $P(RX2,"^",15) S ^TMP("PSOAL",$J,IEN,0)=" Returned to Stock: "_$E($P(RX2,"^",15),4,5)_"/"_$E($P(RX2,"^",15),6,7)_"/"_$E($P(RX2,"^",15),2,3)
E S ^TMP("PSOAL",$J,IEN,0)=" Last Release Date: " D
.S RLD=$S($P(RX2,"^",13):$E($P(RX2,"^",13),4,5)_"/"_$E($P(RX2,"^",13),6,7)_"/"_$E($P(RX2,"^",13),2,3),1:"")
.I $O(^PSRX(RXN,1,0)) F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I D
..I $P(^PSRX(RXN,1,I,0),"^",18) S RLD=$E($P(^(0),"^",18),4,5)_"/"_$E($P(^(0),"^",18),6,7)_"/"_$E($P(^(0),"^",18),2,3)
.S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_$S($G(RLD)]"":RLD,1:" ")
S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" Lot #: "_$P(RX2,"^",4)
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Expires: "_$E($P(RX2,"^",6),4,5)_"/"_$E($P(RX2,"^",6),6,7)_"/"_$E($P(RX2,"^",6),2,3)
S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" MFG: "_$P($G(RX2),"^",8)
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Days Supply: "_$P(RX0,"^",8)_$S($L($P(RX0,"^",8))=1:" ",1:"")
S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" QTY"_$S($P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)]"":" ("_$P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)_")",1:" ( )")_": "_$P(RX0,"^",7)
I $P($G(^PSDRUG($P(RX0,"^",6),5)),"^")]"" D
.S $P(RN," ",79)=" ",IEN=IEN+1
.S ^TMP("PSOAL",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^") K RN
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" # of Refills: "_$P(RX0,"^",9)_$S($L($P(RX0,"^",9))=1:" ",1:"")_" Remaining: "_REFL
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Provider: "_$S($D(^VA(200,$P(RX0,"^",4),0)):$P(^VA(200,$P(RX0,"^",4),0),"^"),1:"UNKNOWN")
N DEAV S DEAV=+$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^",3) I DEAV>1,DEAV<6 D PRV K DEAV
I $P(RX3,"^",3) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Cos-Provider: "_$P(^VA(200,$P(RX3,"^",3),0),"^")
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Routing: "_$S($P(RX0,"^",11)="W":"Window",$P(RX0,"^",11)="P":"Parked",1:"Mail") ;441 PAPI
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Copies: "_$S($P(RX0,"^",18):$P(RX0,"^",18),1:1)
S:$P(RX0,"^",11)="W" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Method of Pickup: "_$G(^PSRX(RXN,"MP"))
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Clinic: "_$S($D(^SC(+$P(RX0,"^",5),0)):$P(^SC($P(RX0,"^",5),0),"^"),1:"Not on File")
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Division: "_$P(^PS(59,$P(RX2,"^",9),0),"^")_" ("_$P(^(0),"^",6)_")"
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Pharmacist: "_$S($P(RX2,"^",3):$P(^VA(200,$P(RX2,"^",3),0),"^"),1:"")
S:$P(RX2,"^",10)&('$G(PSOCOPY)) IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Verified By: "_$P(^VA(200,$P(RX2,"^",10),0),"^")
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Patient Counseling: "_$S($P($G(^PSRX(RXN,"PC")),"^"):"YES",1:"NO")_" "_$S($P($G(^PSRX(RXN,"PC")),"^"):"Was Counseling Understood: "_$S($P($G(^PSRX(RXN,"PC")),"^",2):"YES",1:"NO"),1:"")
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Remarks: "_$P(RX3,"^",7)
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Mail Exemption: "_$$GET1^DIQ(52,RXN,100.2) ;p753
D PC^PSORXVW1
I $P($G(^PSRX(DA,"OR1")),"^",5) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Finished By: "_$P(^VA(200,$P(^PSRX(DA,"OR1"),"^",5),0),"^")
D ^PSORXVW1 S PSOAL=IEN K IEN,ACT,LBL,LOG
I ST<12,$P(RX2,"^",6)<DT S ST=11
S VALM("TITLE")="Rx View "_"("_$P("Error^Active^Non-Verified^Refill^Hold^Non-Verified^Suspended^^^^^Done^Expired^Discontinued^Deleted^Discontinued^Discontinued (Edit)^Provider Hold^","^",ST+2)_")"
S:$P($G(^PSRX(DA,"PKI")),"^") VALMSG="Digitally Signed Order"
S:$P($G(^PSRX(DA,"PKI")),"^",3) VALMSG="Digitally Signed eRx Order"
;
; pso*7*385 - esg - if being called by the BPSVRX routine, call HDR^PSOLMUTL to build the VALMHDR array and then Quit
I $G(BPSVRX) D HDR^PSOLMUTL Q
;
D EN^PSOORAL,KILL I $G(PS)="VIEW" G PSORXVW
K:$G(PS)="VIEW" DA K PS
Q
;
KILL K ^TMP("PSOAL",$J),PSOAL,IEN,^TMP("PSOHDR",$J) I $G(PS)="VIEW" K DA
K ST,RFL,RFLL,RFL1,ST,II,J,N,PHYS,L1,DIRUT,PSDIV,PSEXDT,MED,M1,FFX,DTT,DAT,RX0,RX2,R3,RTN,SIG,STA,P1,PL,P0,Z0,Z1,EXDT,IFN,DIR,DUOUT,DTOUT,PSOELSE
K LBL,I,RFDATE,%H,%I,RN,RFT,%,%I,DFN,GMRA,GMRAL,HDR,POERR,PTST,REFL,RF,RLD,RX3
K RXN,RXOR,SG,VA,VADM,VAERR,VALMBCK,VAPA,X,DIC,REA,ZD,PSOHD,PSOBCK,PSODFN,QUIT
Q
;
PRV ;
N DETN,DEA,LBL,VADD,SPC,ORN S ORN=$P(^PSRX(RXN,"OR1"),"^",2)
S DEA=$$RXDEA^PSOUTIL(RXN)
S LBL=$S(DEA["-":" VA#: ",1:" DEA#: ")
S $P(SPC," ",(28-$L(DEA)))=" "
I $$DETOX^PSSOPKI($P(RX0,"^",6)) S DETN=$$RXDETOX^PSOUTIL(RXN)
I (DEA'="")!($G(DETN)'="") S IEN=IEN+1,$E(^TMP("PSOAL",$J,IEN,0),16)=LBL_DEA_$S($G(DETN)]"":SPC_"DETOX#: "_$G(DETN),1:"")
D PRVAD^PSOPKIV2
I $G(VADD(1))]"" D
.S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Site Address: "_VADD(1)
.S:VADD(2)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" "_VADD(2) S:VADD(3)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" "_VADD(3)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORXVW 11692 printed Dec 13, 2024@02:34:41 Page 2
PSORXVW ;BIR/SAB - ListMan View of a Prescription ;Dec 13, 2021@09:48
+1 ;;7.0;OUTPATIENT PHARMACY;**14,35,46,96,103,88,117,131,146,156,185,210,148,233,260,264,281,359,385,400,391,313,427,504,622,441,651,697,753**;DEC 1997;Build 53
+2 ; Reference to ^PS(55 in ICR #2228
+3 ; Reference to ^PS(50.7 in ICR #2223
+4 ; Reference to ^PSDRUG( in ICR #221
+5 ; Reference to ^VA(200 in ICR #10060
+6 ; Reference to ^SC in ICR #10040
+7 ; Reference to ^DPT in ICR #10035
+8 ; Reference to ^PS(50.606 in ICR #2174
+9 ; Reference to GMRADPT in ICR #10099
+10 ; Reference to $$BADADR^DGUTL3 in ICR #4080
+11 ; Reference to $$POSTSHRT^WVRPCOR in ICR #6174
+12 ;
+13 SET PS="VIEW"
A1 ; - Prescription prompt
+1 SET DIR(0)="FAO^1:30"
SET DIR("A")=PS_" PRESCRIPTION: "
SET (DIR("?"),DIR("??"))="^D HLP^PSORXVW1"
+2 WRITE !
DO ^DIR
IF X=""!$DATA(DIRUT)
if $GET(PS)="VIEW"
KILL DA
KILL PS
GOTO KILL
+3 SET X=$$UP^XLFSTR(X)
SET QUIT=0
+4 IF $EXTRACT(X,1,2)'="E."
SET (DA,PSOVDA)=+$$LKP^PSORXVW1(X)
IF DA<0
GOTO A1
+5 ; esg 12/7/10 - ECME# lookup - PSO*7*359
IF $EXTRACT(X,1,2)="E."
Begin DoDot:1
+6 SET (DA,PSOVDA)=+$$RXNUM^PSOBPSU2($EXTRACT(X,3,$LENGTH(X)))
IF DA<0
WRITE " ??",$CHAR(7)
SET QUIT=1
End DoDot:1
IF QUIT
GOTO A1
+7 ;
+8 ; pso*7*385 - esg - Routine BPSRVX is calling this routine here at entry point DP in order to capture the
+9 ; scratch global data for the View ECME Rx option. Special variable BPSVRX=1 in this case.
DP ; DBIA #4711 entry point from ECME
+1 ;
+2 SET (PSODFN,DFN)=+$PIECE(^PSRX(DA,0),"^",2)
SET PSOLOUD=1
if $PIECE($GET(^PS(55,PSODFN,0)),"^",6)'=2
DO EN^PSOHLUP(PSODFN)
KILL PSOLOUD
+3 DO ICN^PSODPT(PSODFN)
+4 KILL ^TMP("PSOHDR",$JOB)
DO ^VADPT
DO ADD^VADPT
+5 SET ^TMP("PSOHDR",$JOB,1,0)=VADM(1)
+6 NEW PSOBADR,PSOTEMP
+7 SET PSOBADR=$$BADADR^DGUTL3(DFN)
IF PSOBADR
SET PSOTEMP=$$CHKTEMP^PSOBAI(DFN)
Begin DoDot:1
+8 SET ^TMP("PSOHDR",$JOB,1,0)=^TMP("PSOHDR",$JOB,1,0)_" ** BAD ADDRESS INDICATED-("_$SELECT(PSOBADR=1:"UNDELIVERABLE",PSOBADR=2:"HOMELESS",1:"OTHER")_")"_$SELECT(PSOTEMP:" Active Temporary Address",1:"")
End DoDot:1
+9 SET ^TMP("PSOHDR",$JOB,2,0)=$PIECE(VADM(2),"^",2)
+10 SET ^TMP("PSOHDR",$JOB,3,0)=$PIECE(VADM(3),"^",2)
SET ^TMP("PSOHDR",$JOB,4,0)=VADM(4)
SET ^TMP("PSOHDR",$JOB,5,0)=$PIECE(VADM(5),"^",2)
+11 SET POERR=1
DO RE^PSODEM
KILL PSOERR
+12 SET ^TMP("PSOHDR",$JOB,6,0)=$SELECT(+$PIECE(WT,"^",8):$PIECE(WT,"^",9)_" ("_$PIECE(WT,"^")_")",1:"_______ (______)")
+13 SET ^TMP("PSOHDR",$JOB,7,0)=$SELECT($PIECE(HT,"^",8):$PIECE(HT,"^",9)_" ("_$PIECE(HT,"^")_")",1:"_______ (______)")
KILL VM,WT,HT
SET PSOHD=7
+14 SET GMRA="0^0^111"
DO EN1^GMRADPT
SET ^TMP("PSOHDR",$JOB,8,0)=+$GET(GMRAL)
+15 SET ^TMP("PSOHDR",$JOB,14,0)=$$POSTSHRT^WVRPCOR(PSODFN)
+16 DO DEM^VADPT
IF +VADM(6)
Begin DoDot:1
+17 SET SSN=$PIECE(^DPT(PSODFN,0),"^",9)
WRITE !,$CHAR(7),?10,$PIECE(^DPT(PSODFN,0),"^")_" ("_$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)_") DIED "_$PIECE(VADM(6),"^",2),!
+18 WRITE "All Active Medications will be Autocanceled!",!
HANG 2
SET PSODEATH=1
+19 SET ACOM="Date of Death "_$PIECE(VADM(6),"^",2)_"."
SET ZTRTN="CAN^PSOCAN3"
SET ZTDESC="Outpatient Pharmacy Autocancel Due to Death of Patient"
SET ZTSAVE("ACOM")=""
SET ZTSAVE("PSODFN")=""
SET ZTSAVE("PSODEATH")=""
+20 SET ZTIO=""
SET PSOCLC=DUZ
SET ZTSAVE("PSOCLC")=""
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
KILL ACOM,ZTSK,PSODEATH
End DoDot:1
+21 KILL ^TMP("PSOAL",$JOB),PCOMX,PDA,PHI,PRC,ACOM,ANS
+22 SET (DA,RXN)=PSOVDA
KILL PSOVDA
SET RX0=^PSRX(RXN,0)
SET RX2=$GET(^(2))
SET RX3=$GET(^(3))
SET ST=+$GET(^("STA"))
SET RXOR=$GET(^("OR1"))
+23 IF 'RXOR
IF $PIECE(^PSDRUG($PIECE(RX0,"^",6),2),"^")
SET $PIECE(^PSRX(RXN,"OR1"),"^")=$PIECE(^PSDRUG($PIECE(RX0,"^",6),2),"^")
SET RXOR=$PIECE(^PSDRUG($PIECE(RX0,"^",6),2),"^")
+24 SET IEN=0
SET $PIECE(RN," ",12)=" "
+25 NEW APPND,ECME,TITR,ERXIEN
+26 SET APPND=$SELECT($GET(^PSRX(RXN,"IB")):"$",1:"")
+27 ; Returns "" (non-ECME), or "e" (ECME)
SET ECME=$$ECME^PSOBPSUT(RXN)
+28 ; Returns "" (non-Titration), "m" (Maintenance) or "t" (titration)
SET TITR=$$TITRX^PSOUTL(RXN)
+29 SET APPND=APPND_ECME_TITR
+30 IF ECME'=""
SET APPND=APPND_" (ECME#: "_$$ECMENUM^PSOBPSU2(RXN)_")"
+31 IF TITR'=""
SET APPND=APPND_" ("_$SELECT(TITR="t":"Titration",1:"Maintenance")_")"
+32 ;PSO*7.0*697: add eRx indicator and break first line up for readability
+33 SET ERXIEN=$$CHKERX^PSOERXU1($PIECE(RXOR,"^",2))
+34 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=$SELECT($PIECE($GET(^PSRX(RXN,"TPB")),"^"):" TPB Rx #: ",1:" Rx #: ")_$SELECT(ERXIEN:"& ",1:"")
+35 SET ^TMP("PSOAL",$JOB,IEN,0)=^TMP("PSOAL",$JOB,IEN,0)_$PIECE(RX0,"^")_APPND_$EXTRACT(RN,$LENGTH($PIECE(RX0,"^")_APPND)+1,12)
+36 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Orderable Item: "_$SELECT($DATA(^PS(50.7,$PIECE(+RXOR,"^"),0)):$PIECE(^PS(50.7,$PIECE(+RXOR,"^"),0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^(0),"^",2),0),"^"),1:"No Pharmacy Orderable Item")
+37 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=$SELECT($DATA(^PSDRUG("AQ",$PIECE(RX0,"^",6))):" CMOP ",1:" ")_"Drug: "_$PIECE(^PSDRUG($PIECE(RX0,"^",6),0),"^")
+38 if $GET(^PSRX(RXN,"TN"))]""
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Trade Name: "_$GET(^PSRX(RXN,"TN"))
+39 ; Always display the NDC# - PSO*7*427
+40 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" NDC: "_$$GETNDC^PSONDCUT(RXN,0)
+41 DO DOSE^PSORXVW1
+42 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)="Patient Instructions:"
IF $ORDER(^PSRX(RXN,"INS1",0))
Begin DoDot:1
+43 FOR I=0:0
SET I=$ORDER(^PSRX(RXN,"INS1",I))
if 'I
QUIT
Begin DoDot:2
+44 SET MIG=^PSRX(RXN,"INS1",I,0)
+45 DO WORDWRAP^PSOUTLA2(MIG,.IEN,$NAME(^TMP("PSOAL",$JOB)),21)
End DoDot:2
End DoDot:1
+46 KILL MIG,SG
+47 ;*441-IND
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Indications: "_$PIECE($GET(^PSRX(RXN,"IND")),"^")
+48 IF $PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Other Pat. Instruc: "_$SELECT($GET(^PSRX(RXN,"INSS"))]"":^PSRX(RXN,"INSS"),1:"")
Begin DoDot:1
+49 ;*441-IND
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Other Indications: "_$PIECE($GET(^PSRX(RXN,"IND")),"^",3)
End DoDot:1
+50 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" SIG:"
+51 IF '$PIECE($GET(^PSRX(RXN,"SIG")),"^",2)
Begin DoDot:1
+52 SET X=$PIECE($GET(^PSRX(RXN,"SIG")),"^")
DO SIGONE^PSOHELP
SET SIG=$EXTRACT($GET(INS1),2,250)
+53 DO WORDWRAP^PSOUTLA2(SIG,.IEN,$NAME(^TMP("PSOAL",$JOB)),21)
End DoDot:1
GOTO PTST
+54 SET SIGOK=1
+55 FOR I=0:0
SET I=$ORDER(^PSRX(RXN,"SIG1",I))
if 'I
QUIT
Begin DoDot:1
+56 SET MIG=^PSRX(RXN,"SIG1",I,0)
+57 DO WORDWRAP^PSOUTLA2(MIG,.IEN,$NAME(^TMP("PSOAL",$JOB)),21)
End DoDot:1
+58 SET SIGOK=1
KILL MIG,SG
PTST SET $PIECE(RN," ",25)=" "
SET PTST=$SELECT($GET(^PS(53,+$PIECE(RX0,"^",3),0))]"":$PIECE($GET(^PS(53,+$PIECE(RX0,"^",3),0)),"^"),1:"")
SET IEN=IEN+1
+1 SET ^TMP("PSOAL",$JOB,IEN,0)=" Patient Status: "_PTST_$EXTRACT(RN,$LENGTH(PTST)+1,25)
+2 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Issue Date: "_$EXTRACT($PIECE(RX0,"^",13),4,5)_"/"_$EXTRACT($PIECE(RX0,"^",13),6,7)_"/"_$EXTRACT($PIECE(RX0,"^",13),2,3)
+3 SET ^TMP("PSOAL",$JOB,IEN,0)=^TMP("PSOAL",$JOB,IEN,0)_" Fill Date: "_$EXTRACT($PIECE(RX2,"^",2),4,5)_"/"_$EXTRACT($PIECE(RX2,"^",2),6,7)_"/"_$EXTRACT($PIECE(RX2,"^",2),2,3)
+4 ;441 PAPI
SET ROU=$SELECT($PIECE(RX0,"^",11)="W":"Window",$PIECE(RX0,"^",11)="P":"Parked",1:"Mail")
+5 ;441 PAPI
SET REFL=$PIECE(RX0,"^",9)
SET I=0
FOR
SET I=$ORDER(^PSRX(RXN,1,I))
if 'I
QUIT
SET REFL=REFL-1
SET ROU=$SELECT($PIECE(^PSRX(RXN,1,I,0),"^",2)="W":"Window",$PIECE(^PSRX(RXN,1,I,0),"^",2)="P":"Parked",1:"Mail")
+6 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Last Fill Date: "_$EXTRACT($PIECE(RX3,"^"),4,5)_"/"_$EXTRACT($PIECE(RX3,"^"),6,7)_"/"_$EXTRACT($PIECE(RX3,"^"),2,3)
+7 DO CMOP^PSOORNE3
SET DA=RXN
+8 SET ^TMP("PSOAL",$JOB,IEN,0)=^TMP("PSOAL",$JOB,IEN,0)_" ("_ROU_$SELECT($GET(PSOCMOP)]"":", "_PSOCMOP,1:"")_")"
KILL ROU,PSOCMOP
+9 SET IEN=IEN+1
IF $PIECE(RX2,"^",15)
SET ^TMP("PSOAL",$JOB,IEN,0)=" Returned to Stock: "_$EXTRACT($PIECE(RX2,"^",15),4,5)_"/"_$EXTRACT($PIECE(RX2,"^",15),6,7)_"/"_$EXTRACT($PIECE(RX2,"^",15),2,3)
+10 IF '$TEST
SET ^TMP("PSOAL",$JOB,IEN,0)=" Last Release Date: "
Begin DoDot:1
+11 SET RLD=$SELECT($PIECE(RX2,"^",13):$EXTRACT($PIECE(RX2,"^",13),4,5)_"/"_$EXTRACT($PIECE(RX2,"^",13),6,7)_"/"_$EXTRACT($PIECE(RX2,"^",13),2,3),1:"")
+12 IF $ORDER(^PSRX(RXN,1,0))
FOR I=0:0
SET I=$ORDER(^PSRX(RXN,1,I))
if 'I
QUIT
Begin DoDot:2
+13 IF $PIECE(^PSRX(RXN,1,I,0),"^",18)
SET RLD=$EXTRACT($PIECE(^(0),"^",18),4,5)_"/"_$EXTRACT($PIECE(^(0),"^",18),6,7)_"/"_$EXTRACT($PIECE(^(0),"^",18),2,3)
End DoDot:2
+14 SET ^TMP("PSOAL",$JOB,IEN,0)=^TMP("PSOAL",$JOB,IEN,0)_$SELECT($GET(RLD)]"":RLD,1:" ")
End DoDot:1
+15 SET ^TMP("PSOAL",$JOB,IEN,0)=^TMP("PSOAL",$JOB,IEN,0)_" Lot #: "_$PIECE(RX2,"^",4)
+16 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Expires: "_$EXTRACT($PIECE(RX2,"^",6),4,5)_"/"_$EXTRACT($PIECE(RX2,"^",6),6,7)_"/"_$EXTRACT($PIECE(RX2,"^",6),2,3)
+17 SET ^TMP("PSOAL",$JOB,IEN,0)=^TMP("PSOAL",$JOB,IEN,0)_" MFG: "_$PIECE($GET(RX2),"^",8)
+18 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Days Supply: "_$PIECE(RX0,"^",8)_$SELECT($LENGTH($PIECE(RX0,"^",8))=1:" ",1:"")
+19 SET ^TMP("PSOAL",$JOB,IEN,0)=^TMP("PSOAL",$JOB,IEN,0)_" QTY"_$SELECT($PIECE($GET(^PSDRUG($PIECE(RX0,"^",6),660)),"^",8)]"":" ("_$PIECE($GET(^PSDRUG($PIECE(RX0,"^",6),660)),"^",8)_")",1:" ( )")_": "_$PIECE(RX0,"^",7)
+20 IF $PIECE($GET(^PSDRUG($PIECE(RX0,"^",6),5)),"^")]""
Begin DoDot:1
+21 SET $PIECE(RN," ",79)=" "
SET IEN=IEN+1
+22 SET ^TMP("PSOAL",$JOB,IEN,0)=$EXTRACT(RN,$LENGTH("QTY DSP MSG: "_$PIECE(^PSDRUG($PIECE(RX0,"^",6),5),"^"))+1,79)_"QTY DSP MSG: "_$PIECE(^PSDRUG($PIECE(RX0,"^",6),5),"^")
KILL RN
End DoDot:1
+23 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" # of Refills: "_$PIECE(RX0,"^",9)_$SELECT($LENGTH($PIECE(RX0,"^",9))=1:" ",1:"")_" Remaining: "_REFL
+24 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Provider: "_$SELECT($DATA(^VA(200,$PIECE(RX0,"^",4),0)):$PIECE(^VA(200,$PIECE(RX0,"^",4),0),"^"),1:"UNKNOWN")
+25 NEW DEAV
SET DEAV=+$PIECE($GET(^PSDRUG(+$PIECE(RX0,"^",6),0)),"^",3)
IF DEAV>1
IF DEAV<6
DO PRV
KILL DEAV
+26 IF $PIECE(RX3,"^",3)
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Cos-Provider: "_$PIECE(^VA(200,$PIECE(RX3,"^",3),0),"^")
+27 ;441 PAPI
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Routing: "_$SELECT($PIECE(RX0,"^",11)="W":"Window",$PIECE(RX0,"^",11)="P":"Parked",1:"Mail")
+28 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Copies: "_$SELECT($PIECE(RX0,"^",18):$PIECE(RX0,"^",18),1:1)
+29 if $PIECE(RX0,"^",11)="W"
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Method of Pickup: "_$GET(^PSRX(RXN,"MP"))
+30 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Clinic: "_$SELECT($DATA(^SC(+$PIECE(RX0,"^",5),0)):$PIECE(^SC($PIECE(RX0,"^",5),0),"^"),1:"Not on File")
+31 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Division: "_$PIECE(^PS(59,$PIECE(RX2,"^",9),0),"^")_" ("_$PIECE(^(0),"^",6)_")"
+32 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Pharmacist: "_$SELECT($PIECE(RX2,"^",3):$PIECE(^VA(200,$PIECE(RX2,"^",3),0),"^"),1:"")
+33 if $PIECE(RX2,"^",10)&('$GET(PSOCOPY))
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Verified By: "_$PIECE(^VA(200,$PIECE(RX2,"^",10),0),"^")
+34 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Patient Counseling: "_$SELECT($PIECE($GET(^PSRX(RXN,"PC")),"^"):"YES",1:"NO")_" "_$SELECT(...
... $PIECE($GET(^PSRX(RXN,"PC")),"^"):"Was Counseling Understood: "_$SELECT($PIECE($GET(^PSRX(RXN,"PC")),"^",2):"YES",1:"NO"),1:"")
+35 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Remarks: "_$PIECE(RX3,"^",7)
+36 ;p753
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Mail Exemption: "_$$GET1^DIQ(52,RXN,100.2)
+37 DO PC^PSORXVW1
+38 IF $PIECE($GET(^PSRX(DA,"OR1")),"^",5)
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Finished By: "_$PIECE(^VA(200,$PIECE(^PSRX(DA,"OR1"),"^",5),0),"^")
+39 DO ^PSORXVW1
SET PSOAL=IEN
KILL IEN,ACT,LBL,LOG
+40 IF ST<12
IF $PIECE(RX2,"^",6)<DT
SET ST=11
+41 SET VALM("TITLE")="Rx View "_"("_$PIECE("Error^Active^Non-Verified^Refill^Hold^Non-Verified^Suspended^^^^^Done^Expired^Discontinued^Deleted^Discontinued^Discontinued (Edit)^Provider Hold^","^",ST+2)_")"
+42 if $PIECE($GET(^PSRX(DA,"PKI")),"^")
SET VALMSG="Digitally Signed Order"
+43 if $PIECE($GET(^PSRX(DA,"PKI")),"^",3)
SET VALMSG="Digitally Signed eRx Order"
+44 ;
+45 ; pso*7*385 - esg - if being called by the BPSVRX routine, call HDR^PSOLMUTL to build the VALMHDR array and then Quit
+46 IF $GET(BPSVRX)
DO HDR^PSOLMUTL
QUIT
+47 ;
+48 DO EN^PSOORAL
DO KILL
IF $GET(PS)="VIEW"
GOTO PSORXVW
+49 if $GET(PS)="VIEW"
KILL DA
KILL PS
+50 QUIT
+51 ;
KILL KILL ^TMP("PSOAL",$JOB),PSOAL,IEN,^TMP("PSOHDR",$JOB)
IF $GET(PS)="VIEW"
KILL DA
+1 KILL ST,RFL,RFLL,RFL1,ST,II,J,N,PHYS,L1,DIRUT,PSDIV,PSEXDT,MED,M1,FFX,DTT,DAT,RX0,RX2,R3,RTN,SIG,STA,P1,PL,P0,Z0,Z1,EXDT,IFN,DIR,DUOUT,DTOUT,PSOELSE
+2 KILL LBL,I,RFDATE,%H,%I,RN,RFT,%,%I,DFN,GMRA,GMRAL,HDR,POERR,PTST,REFL,RF,RLD,RX3
+3 KILL RXN,RXOR,SG,VA,VADM,VAERR,VALMBCK,VAPA,X,DIC,REA,ZD,PSOHD,PSOBCK,PSODFN,QUIT
+4 QUIT
+5 ;
PRV ;
+1 NEW DETN,DEA,LBL,VADD,SPC,ORN
SET ORN=$PIECE(^PSRX(RXN,"OR1"),"^",2)
+2 SET DEA=$$RXDEA^PSOUTIL(RXN)
+3 SET LBL=$SELECT(DEA["-":" VA#: ",1:" DEA#: ")
+4 SET $PIECE(SPC," ",(28-$LENGTH(DEA)))=" "
+5 IF $$DETOX^PSSOPKI($PIECE(RX0,"^",6))
SET DETN=$$RXDETOX^PSOUTIL(RXN)
+6 IF (DEA'="")!($GET(DETN)'="")
SET IEN=IEN+1
SET $EXTRACT(^TMP("PSOAL",$JOB,IEN,0),16)=LBL_DEA_$SELECT($GET(DETN)]"":SPC_"DETOX#: "_$GET(DETN),1:"")
+7 DO PRVAD^PSOPKIV2
+8 IF $GET(VADD(1))]""
Begin DoDot:1
+9 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Site Address: "_VADD(1)
+10 if VADD(2)]""
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" "_VADD(2)
if VADD(3)]""
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" "_VADD(3)
End DoDot:1
+11 QUIT
+12 ;
