PSOERX1A ;ALB/BWF - eRx Utilities/RPC's ; 8/3/2016 5:14pm
;;7.0;OUTPATIENT PHARMACY;**467,527,508,551,581,617,669,700,743,746**;DEC 1997;Build 106
;
Q
; select an item
SI ;
N RESP,ERXIEN,ERXDAT,LINE,LINEVAR,ERXPAT,ERXLOCK,DIR,NEWRXIEN,REQIEN,MTYPE,Y
D FULL^VALM1
S DIR(0)="N^"_VALMBG_":"_VALMLST_":0" D ^DIR
I 'Y S VALMBCK="R" Q
S RESP=Y
S ERXIEN=$O(@VALMAR@("IDX",RESP,"")) Q:'ERXIEN
; Get the patient IEN
S ERXPAT=$$GETPAT^PSOERXU5(ERXIEN)
S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
I 'ERXPAT,"IEOE"[MTYPE D EN^PSOERX1(ERXIEN) S VALMBCK="R" Q
I '$D(PCV) D Q
.S ERXLOCK=$$L(ERXPAT,1)
.I 'ERXLOCK S DIR(0)="E" D ^DIR K DIR S VALMBCK="R" Q
.D EN^PSOERX1(ERXIEN)
.D UL(ERXPAT)
.K % S VALMBCK="R"
D EN^PSOERX1(ERXIEN)
K %
S VALMBCK="R"
Q
SBN ;
N Y,ERXIEN,ERXPAT,DIR,MTYPE
D FULL^VALM1
S Y=+$P(XQORNOD(0),"=",2)
I 'Y S VALMBCK="R" Q
S ERXIEN=$O(@VALMAR@("IDX",Y,"")) Q:'ERXIEN
S ERXPAT=$$GETPAT^PSOERXU5(ERXIEN)
S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
I 'ERXPAT,"IEOE"[MTYPE D EN^PSOERX1(ERXIEN) S VALMBCK="R" Q
I '$D(PCV) D Q
.S ERXLOCK=$$L(ERXPAT,1)
.I 'ERXLOCK S DIR(0)="E" D ^DIR K DIR S VALMBCK="R" Q
.D EN^PSOERX1(ERXIEN)
.D UL(ERXPAT)
.S VALMBCK="R" K %
D EN^PSOERX1(ERXIEN)
S VALMBCK="R"
K %
Q
L(DFN,DIS,SILENT) ; Locks an eRx Patient
; Input: DFN - Pointer to eRx Patient (Pointer to #52.46)
; DIS - Display name of the user currently locking the record
; (o)SILENT - 1: Silent call - Nothing displayed back | 0: Display information about the Lock on the screen
;Output: 1 - Record Locked Successfully | 0 - Record already Locked by another user
I $G(PSONOLCK) Q 1
N FLAG,LKTOUT S ^XTMP("PSOERXLOCK",0)=$$PDATE,LKTOUT=0
S LKTOUT=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":0,$G(DILOCKTM)>0:DILOCKTM,1:3)
; TEMP CHANGE UNTIL MBM GETS OFF Class 3 option
I $$GET1^DIQ(59.7,1,102,"I")="MBM",$G(^XTMP("PSOERXLOCK",DFN)) Q 0
; If a lock is already established for this patient and is associated with the current user
I $P($G(^XTMP("PSOERXLOCK",DFN)),"^",1)=DUZ D Q FLAG
. L +^XTMP("PSOERXLOCK",DFN):LKTOUT S FLAG=$T
. I 'FLAG W:'$G(SILENT) !,"You have this patient locked in another open session"
I '$D(^XTMP("PSOERXLOCK",DFN)) D Q FLAG
. L +^XTMP("PSOERXLOCK",DFN):LKTOUT S FLAG=$T
. I FLAG D
. . D NOW^%DTC S ^XTMP("PSOERXLOCK",DFN)=DUZ_"^"_%
. . S FDA(52.46,DFN_",",6)=DUZ
. . D UPDATE^DIE(,"FDA") K FDA
I $D(^XTMP("PSOERXLOCK",DFN)) Q $$R
;
UL(DFN) ; unlock
I $G(PSONOLCK) Q
L -^XTMP("PSOERXLOCK",DFN) K ^XTMP("PSOERXLOCK",DFN)
Q
;
R() ; check lock on node
N MBMSITE
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
N LKTOUT S LKTOUT=$S($G(MBMSITE):0,$G(DILOCKTM)>0:DILOCKTM,1:3)
;if user has same patient already locked, Q 1, will only lock once
I $P($G(^XTMP("PSOERXLOCK",DFN)),"^")=DUZ Q 1
L +^XTMP("PSOERXLOCK",DFN):LKTOUT I $T D Q 1
.D NOW^%DTC S ^XTMP("PSOERXLOCK",DFN)=DUZ_"^"_%
.S FDA(52.46,DFN_",",6)=DUZ
.D UPDATE^DIE(,"FDA") K FDA
I $T=0 W:DIS=1&'$G(SILENT) !,$$WHO(DFN) S Y=$P($G(^XTMP("PSOERXLOCK",DFN)),"^",2) X ^DD("DD") Q $S(DIS=0:0_"^"_$P($G(^VA(200,+$P($G(^XTMP("PSOERXLOCK",DFN)),"^"),0)),"^")_"^"_Y,1:0)
;
PDATE() ;
N X1,X2 S X1=DT,X2=+14 D C^%DTC
Q X_"^"_DT_"^eRx Pharmacy patient locks"
;
WHO(DFN) ;
S Y=$P($G(^XTMP("PSOERXLOCK",DFN)),"^",2) X ^DD("DD")
Q $P($G(^VA(200,+$P($G(^XTMP("PSOERXLOCK",DFN)),"^"),0)),"^")_" is editing orders for this patient ("_Y_")"
;
;
; TEXT - variable where text is stored (passed by reference)
; HDR - header text
; DATA - data associated with the header
; STRT - start location (column)
; LEN - total length for header and data
ADDITEM(TEXT,HDR,DATA,STRT,LEN) ;
N LLEN,FULLDAT,L
S FULLDAT=$G(HDR)_$G(DATA)
S TEXT=$G(TEXT,"") I STRT=1 S TEXT=TEXT_$E(FULLDAT,1,LEN) Q
S LLEN=$L(TEXT)
I LLEN<STRT D
.F L=$L(TEXT):1:STRT-1 D
..S TEXT=TEXT_" "
S TEXT=TEXT_$E(FULLDAT,1,LEN)
Q
; provider information display
PROV ;
D FULL^VALM1 I $$DONOTFIL^PSOERXUT(PSOIEN) S VALMBCK="R" Q
N STAT,RESVAL
S RESVAL=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
S STAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
I STAT="RXE",'$$RXEPRMT^PSOERXU7(PSOIEN) Q
I STAT="CXE",(RESVAL="A"!(RESVAL="AWC"))!(RESVAL="V"),'$$RXEPRMT^PSOERXU7(PSOIEN) Q
I '$$GET1^DIQ(52.49,PSOIEN,2.3,"I") S XQORM("B")="Edit"
D EN^PSOERXR1
D INIT^PSOERSE1
Q
; patient information display
PAT ;
D FULL^VALM1 I $$DONOTFIL^PSOERXUT(PSOIEN) S VALMBCK="R" Q
N STAT,RESVAL
S RESVAL=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
S STAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
I STAT="RXE",'$$RXEPRMT^PSOERXU7(PSOIEN) Q
I STAT="CXE",(RESVAL="A"!(RESVAL="AWC"))!(RESVAL="V"),'$$RXEPRMT^PSOERXU7(PSOIEN) Q
I '$$GET1^DIQ(52.49,PSOIEN,.05,"I") S XQORM("B")="Edit"
D EN^PSOERXP1
D INIT^PSOERSE1
Q
; drug information display
DRUG ;
D FULL^VALM1 I $$DONOTFIL^PSOERXUT(PSOIEN) S VALMBCK="R" Q
N STAT,RESVAL
S RESVAL=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
S STAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
I STAT="RXE",'$$RXEPRMT^PSOERXU7(PSOIEN) Q
I STAT="CXE",(RESVAL="A"!(RESVAL="AWC"))!(RESVAL="V"),'$$RXEPRMT^PSOERXU7(PSOIEN) Q
I '$$GET1^DIQ(52.49,PSOIEN,3.2,"I") S XQORM("B")="Edit"
D EN^PSOERXD1
D INIT^PSOERSE1
Q
; edit validation
; EDTYPE - D=drug, P=patient, PR=provider
EDIT(EDTYP,SBN) ;
N MBMSITE,DIR,Y,ITEM,RES,TAG,PQUIT,RXSTAT,SUGVARX
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
D FULL^VALM1
S SBN=$G(SBN,"")
S VALMBCK="R"
Q:'$G(PSOIEN)
S RXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E") I RXSTAT="RJ"!(RXSTAT="RM")!(RXSTAT="PR")!($G(MBMSITE)&($E(RXSTAT,1,3)="REM")) D Q
. W !!,"Cannot edit a prescription with a status of 'Rejected', 'Removed',",!,"or 'Processed",!
. S DIR(0)="E" D ^DIR
S PSOIENS=PSOIEN_","
Q:'$D(EDTYP)
I EDTYP="D" D Q
. S SUGVARX=$$MATCHSUG^PSOERUT4(PSOIEN)
. I $G(SUGVARX) D Q
. . W !?64,"Updating..."
. . D SAVEDRUG^PSOERUT2(PSOIEN,SUGVARX)
. . K @VALMAR D INIT^PSOERXD1 S VALMBCK="R"
. . H .5 W "done." H 1
. W !
. D PLSTRNG(1,10,.RES,SBN)
. I '$O(RES(0)) Q
. I $D(RES(1)) D DERX1^PSOERXD2(PSOIEN,PSOIENS)
. S (ITEM,PQUIT)=0 F S ITEM=$O(RES(ITEM)) Q:'ITEM!(PQUIT) D
. . S TAG="VDRG"_ITEM_"^PSOERXD2(PSOIEN,PSOIENS)" D @TAG
. K @VALMAR D INIT^PSOERXD1
I EDTYP="P" D VPAT K @VALMAR D INIT^PSOERXP1 Q
I EDTYP="PR" D VPROV K @VALMAR D INIT^PSOERXR1 Q
Q
; edit provider
VPROV ;
N MBMSITE,EXPRVIEN,VAPRVIEN,MANVAL,PRVDAT,EXPRNAME,EXPRLNAM,EXPRFNAM,PSOIENS,ERXMMFLG,FDA
N EXPRIENS,SELPRV,QUIT,VAPNM,NEWPIEN,VANPI,MTYPE,RESTYPE,ERXSTAT,NEWVAL,DONE,PSOQUIT
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
S PSOIENS=PSOIEN_","
S VAPNM=$$GET1^DIQ(52.49,PSOIEN,2.3,"E")
S EXPRVIEN=$$GET1^DIQ(52.49,PSOIEN,2.1,"I")
S EXPRIENS=EXPRVIEN_","
D GETS^DIQ(52.48,EXPRIENS,".01;.02;.03;1.5;1.6","E","PRVDAT")
S EXPRNAME=$G(PRVDAT(52.48,EXPRIENS,.01,"E"))
S EXPRLNAM=$G(PRVDAT(52.48,EXPRIENS,.02,"E"))
S EXPRFNAM=$G(PRVDAT(52.48,EXPRIENS,.03,"E"))
S MANVAL=$$GET1^DIQ(52.49,PSOIEN,1.3,"I")
S MTYPE=$$GET1^DIQ(52.49,PSOIEN,.08,"I")
S VAPIEN=$$GET1^DIQ(52.49,PSOIEN,2.3,"I")
S RESTYPE=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
S ERXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
;
; There is a Provider currently selected
S PSOQUIT=0
I VAPIEN D I PSOQUIT Q
. K DIR W !,"Current Vista Provider: "_VAPNM,!
. S DIR(0)="YO",DIR("A")="Would you like to edit the Provider"
. I MANVAL S DIR("A",1)="This Provider has already been validated."
. S DIR("B")="NO" D ^DIR I 'Y!$D(DIRUT)!$D(DIROUT) S PSOQUIT=1 Q
. W !
; Suggesting a VistA Provider
S NEWPIEN=$$MATCHSUG^PSOERPV1(PSOIEN)
;
I '$G(NEWPIEN) D I PSOQUIT Q
. K DIC W ! S DIC=200,DIC(0)="QEAM",DIC("A")="VISTA PROVIDER: ",DIC("S")="I $$CHKPRV2^PSOERX1A(Y)"
. I $G(MBMSITE) S DIC("W")="D PRVIDS^PSOERPV1"
. D ^DIC I Y<0 S PSOQUIT=1 Q
. S NEWPIEN=+Y
. D CMPPRV^PSOERPV1(PSOIEN,NEWPIEN)
. S ERXMMFLG=$$PRVWARN("EP",PSOIEN,NEWPIEN)
. S DIR(0)="Y",DIR("A")="Would you like to use this Provider"
. S DIR("B")=$S($G(ERXMMFLG):"NO",1:"YES") D ^DIR I 'Y!$D(DIRUT)!$D(DIROUT) S PSOQUIT=1 Q
;
W !?64,"Updating..."
; Setting the eRx Audit Log
S NEWVAL(1)=$$GET1^DIQ(200,NEWPIEN,.01)_" (DEA#: "_$P($$VADEA^PSOERXU8(NEWPIEN,PSOIEN),"^",2)_")"
D AUDLOG^PSOERXUT(+PSOIENS,"PROVIDER",DUZ,.NEWVAL)
;
; change existing entry
S FDA(52.49,PSOIENS,2.3)=NEWPIEN
; Removing Manual Validation fields
S FDA(52.49,PSOIENS,1.3)="",FDA(52.49,PSOIENS,1.8)="",FDA(52.49,PSOIENS,1.9)=""
; If auto-matched, change PROV STAT (AUTO-VAL) #1.2 to 2 (VALIDATED/EDITED)
I $$GET1^DIQ(52.49,+PSOIENS,1.2,"I")=1 S FDA(52.49,PSOIENS,1.2)=2
D FILE^DIE(,"FDA")
;
; Updating eRx Status to In Progress
I MTYPE="N" D UPDSTAT^PSOERXU1(PSOIEN,"I")
I MTYPE="RE",RESTYPE="R" D UPDSTAT^PSOERXU1(PSOIEN,"RXI") Q
I MTYPE="RE" D UPDSTAT^PSOERXU1(PSOIEN,"RXW")
I MTYPE="CX" D UPDSTAT^PSOERXU1(PSOIEN,"CXI")
H .5 W "done.",$C(7) H 1
Q
;
PRVWARN(ACTION,PSOIEN,VAPIEN) ; Check whether the Provider Select is valid or not
; Input:(r)ACTION - Ation being peformed ("EP": Edit Provider | "VP": Validate Provider)
; (r)PSOIEN - Pointer to the ERX HOLDING QUEUE file (#52.49)
; (r)VAPIEN - Provider -Pointer to the NEW PERSON file (#200)
;Output: 1 - No Issues Found with Provider Selected | 2 - Issues Found With Provider Select by Ok to to proceed | 0 - Invalid Provider Selection
N EXPRVNPI,VANPI,ERXDEA,VADEA,I,ERXMSG,ERXPIEN,EXPRVDEA,ERXDRIEN
S ERXPIEN=$$GET1^DIQ(52.49,PSOIEN,2.1,"I")
S ERXDRIEN=+$$GET1^DIQ(52.49,PSOIEN,3.2,"I")
I '$G(VAPIEN) S VAPIEN=$$GET1^DIQ(52.49,PSOIEN,2.3,"I") I '$G(VAPIEN) Q 0
D PRDRVAL^PSOERXUT(.ERXMSG,ACTION,PSOIEN,VAPIEN,ERXDRIEN)
I +ERXMSG Q 1
W !!,"*******************************",$S($P(ERXMSG,"^",2)="W":" WARNING(S) ",1:"INVALID PROVIDER"),"*********************************"
S I=0 F S I=$O(ERXMSG(I)) Q:'I W !,$P(ERXMSG(I),"^")
W !,"********************************************************************************"
I $P(ERXMSG,"^",2)="W" Q 2
Q 0
CHKPRV2(Y) ;
;Ref. to ^VA(200 supp. by IA 224
I '$P($G(^VA(200,Y,"PS")),U) Q 0
Q 1
; validate drug
; prompt list or range
; LOW - lowest number to prompt for
; HIGH - highest number to prompt for
; EDIT - returned list of selected values
; EDIT(n1)=""
; EDIT(n2)=""
; EDIT(n3)=""
PLSTRNG(LOW,HIGH,EDIT,SBN) ;
N DIR,DONE,DONE2,Y,NUMCHK,NUM,VAL,I,LIST
I '$G(LOW)!'$G(HIGH) S LIST=0 Q
S DONE=0
F D Q:DONE
.I $$GET1^DIQ(52.49,PSOIEN,3.2,"I")="" S Y="A"
.I '$D(Y),'$O(^PS(52.49,PSOIEN,21,0)) S Y="A"
.I SBN']"",'$D(Y)!($G(Y)[" ")!($G(Y)[".") D
..S DIR(0)="FO^",DIR("A")="Which field(s) would you like to edit? ("_LOW_"-"_HIGH_") or 'A'll"
..S DIR("?")="Enter a number, range, or a list of numbers (i.e. 3, 1-5, 3,7,9, or 'A'll)"
..S DIR("B")="A"
..D ^DIR K DIR I $D(DIRUT)!$D(DTOUT) S DONE=1 Q
..I Y="^" S DONE=1 Q
.I SBN']"",Y["-",Y["," D Q
..W !!,"Invalid Response."
..W !,"Answer must be numeric (1-10), a series of numbers (3,5,7), 'A' or 'ALL'."
..S DIR(0)="E" D ^DIR K Y,DIR I $D(DIRUT)!$D(DTOUT) S DONE=1 Q
.I SBN']"",(Y[".")!(Y[" ") D Q
..W !!,"Invalid Response."
..W !,"Answer must be numeric (1-10), a series of numbers (3,5,7), 'A' or 'ALL'."
..S DIR(0)="E" D ^DIR K DIR I $D(DIRUT)!$D(DTOUT) S DONE=1 Q
..I Y'[" " K Y
.I SBN]"",'$D(Y) S Y=SBN
.Q:Y["."
.I Y="^" S DONE=1 Q
.S Y=$$UP^XLFSTR(Y)
.I Y="A"!(Y="ALL") D Q
..F I=LOW:1:HIGH D
...S EDIT(I)=""
..S DONE=1
.; check for a range or list of numbers
.I Y'["-",Y'[",",Y'<LOW,Y'>HIGH S EDIT(+Y)="" S DONE=1 Q
.I Y?1.2N1"-"1.2N D
..F I=$P(Y,"-"):1:$P(Y,"-",2) D
...Q:I<LOW!(I>HIGH)
...S EDIT(I)=""
.I $D(EDIT) S DONE=1 Q
.I Y["," D
..; check to see if there are alpha-numerics if there are, quit and reprompt
..S NUMCHK=$TR(Y,",","") I 'NUMCHK W !,"Invalid response." Q
..S DONE2=0
..F NUM=1:1 D Q:DONE2
...S VAL=$P(Y,",",NUM)
...I 'VAL S DONE2=1 Q
...I VAL<LOW!(VAL>HIGH) Q
...S EDIT(VAL)=""
.I $D(EDIT) S DONE=1 Q
.W !,"Invalid Response."
.W !,"Answer must be numeric (1-10), a series of numbers (3,5,7), 'A' or 'ALL'."
.K DIR S DIR(0)="E" D ^DIR K Y,DIR
Q
; Match Patient
VPAT ;
N MBMSITE,ERXPIEN,VAPIEN,MANVAL,ERXLNAME,ERXFNAME,DIR,Y,PSOIENS,VAPIEN,MANVAL,DIC,SELPAT,PDONE,DFN,I,VADM
N ERXSTAT,RESTYPE,MTYPE,PSOQUIT,FDA,GMRA,GMRAL
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
S PSOIENS=PSOIEN_","
S ERXPIEN=$$GET1^DIQ(52.49,PSOIEN,.04,"I")
S ERXLNAME=$$GET1^DIQ(52.46,ERXPIEN,.02,"E")
S ERXFNAME=$$GET1^DIQ(52.46,ERXPIEN,.03,"E")
S VAPIEN=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
S MANVAL=$$GET1^DIQ(52.49,PSOIEN,1.7,"I")
S RESTYPE=$$GET1^DIQ(52.49,PSOIEN,52.1)
S ERXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
S MTYPE=$$GET1^DIQ(52.49,PSOIEN,.08,"I")
; There is a patient currently selected
S PSOQUIT=0
I VAPIEN D I PSOQUIT Q
. K DIR W !,"Current Vista patient: "_$$GET1^DIQ(2,VAPIEN,.01,"E"),!
. S DIR(0)="YO",DIR("A")="Would you like to edit the patient"
. I MANVAL S DIR("A",1)="This Patient has already been validated."
. S DIR("B")="NO" D ^DIR I 'Y!$D(DIRUT)!$D(DIROUT) S PSOQUIT=1 Q
; Suggesting a VistA Patient
S SELPAT=$$MATCHSUG^PSOERPT1(PSOIEN)
;
I '$G(SELPAT) D I PSOQUIT Q
. K DIC,DIR W ! S DIC=2,DIC(0)="QEAM",DIC("A")="VISTA PATIENT: ",DIC("S")="I '$$DEAD^PSONVARP(Y)"
. I $G(MBMSITE) S DIC("W")="D PATIDS^PSOERPT1"
. D ^DPTLK I Y<0 S PSOQUIT=1 Q
. S SELPAT=+Y
. D CMPPAT^PSOERPT1(PSOIEN,SELPAT)
. S ERXMMFLG=$$PATWARN("EP",PSOIEN,SELPAT)
. S DIR(0)="Y",DIR("A")="Would you like to use this patient"
. S DIR("B")=$S($G(ERXMMFLG):"NO",1:"YES") D ^DIR I 'Y!$D(DIRUT)!$D(DIROUT) S PSOQUIT=1 Q
;
W !?64,"Updating..."
;Setting the eRx Audit Log
S DFN=SELPAT D DEM^VADPT
N NEWVAL S NEWVAL(1)=$$GET1^DIQ(2,SELPAT,.01)_" (L4SSN: "_$P($P(VADM(2),"^",2),"-",3)_" | DOB: "_$P(VADM(3),"^",2)_")"
D AUDLOG^PSOERXUT(+PSOIENS,"PATIENT",DUZ,.NEWVAL)
;
;Updating eRx Record w/ New Patient
S FDA(52.49,PSOIENS,.05)=SELPAT
S FDA(52.49,PSOIENS,1.7)="",FDA(52.49,PSOIENS,1.13)="",FDA(52.49,PSOIENS,1.14)=""
; If auto-matched, change PAT STATUS (AUTO-VAL) #1.6 to 2 (VALIDATED/EDITED)
I $$GET1^DIQ(52.49,+PSOIENS,1.6,"I")=1 S FDA(52.49,PSOIENS,1.6)=2
D FILE^DIE(,"FDA")
;
; VistA Patient ChampVA Eligibility Check (MbM Only)
I $G(MBMSITE),'$$CHVAELIG^PSOERXU9(SELPAT) D Q
. I ",N,I,W,RXI,RXN,RXW,RXR,CXI,CXN,CXW,"[(","_$G(ERXSTAT)_",") D
. . D UPDSTAT^PSOERXU1(PSOIEN,"HEL","Hold due to Eligibility Issue")
. . W !!,"This eRx has been put on Hold (HEL) because the VistA Patient ("_$$GET1^DIQ(2,SELPAT,.01)_") is not Eligible for ChampVA Rx Benefit."
. . K DIR D PAUSE^VALM1
. D AUTOHOLD^PSOERX1E("E",PSOIEN,SELPAT)
;
;VistA Patient Allergy Check (MbM Only)
I $G(MBMSITE) D I $G(GMRAL)="" Q
. S DFN=SELPAT,GMRA="0^0^111" D EN1^GMRADPT I $G(GMRAL)'="" Q
. I ",N,I,W,RXI,RXN,RXW,RXR,CXI,CXN,CXW,"[(","_$G(ERXSTAT)_",") D
. . D UPDSTAT^PSOERXU1(PSOIEN,"HAL","Hold for Allergy Assessment")
. . W !!,"This eRx has been put on Hold (HAL) because the VistA Patient ("_$$GET1^DIQ(2,SELPAT,.01)_") does not have an Allergy Assessment.."
. . K DIR D PAUSE^VALM1
. D AUTOHOLD^PSOERX1E("A",PSOIEN,SELPAT)
;
;Updating eRx Status to In Progress
I MTYPE="N" D UPDSTAT^PSOERXU1(PSOIEN,"I")
I MTYPE="RE" D UPDSTAT^PSOERXU1(PSOIEN,"RXI")
I MTYPE="CX" D UPDSTAT^PSOERXU1(PSOIEN,"CXI")
I MTYPE="RE" D UPDSTAT^PSOERXU1(PSOIEN,"RXI")
I MTYPE="CX" D UPDSTAT^PSOERXU1(PSOIEN,"CXI")
I ERXSTAT="N" D UPDSTAT^PSOERXU1(PSOIEN,"I")
H .5 W "done.",$C(7) H 1
Q
;
PATWARN(ACTION,PSOIEN,SELPAT) ; Check whether the Patient Select is valid or not
; Input:(r)ACTION - Ation being peformed ("EP": Edit Patient | "VP": Validate Patient)
; (r)PSOIEN - Pointer to the ERX HOLDING QUEUE file (#52.49)
; (r)SELPAT - Patient -Pointer to the PATIENT file (#2)
;Output: 1 - No Issues Found with Patient Selected | 2 - Issues Found With Patient selected but Ok to proceed | 0 - Invalid Patient Selection
N MBMSITE,ERXPIEN,ERXSSN,ERXDOB,ERXGEN,ERXMMFLG,ERXMSG,EXPRVDEA,ERXCNT,I,VADM,GMRA,GMRAL
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
S ERXCNT=0,ERXMMFLG=1
S ERXPIEN=$$GET1^DIQ(52.49,PSOIEN,.04,"I")
S ERXSSN=$$GET1^DIQ(52.46,ERXPIEN,1.4,"E"),ERXSSN=$TR(ERXSSN,"-","")
S ERXDOB=$$GET1^DIQ(52.46,ERXPIEN,.08,"I")
S ERXGEN=$$GET1^DIQ(52.46,ERXPIEN,.07,"I")
; if the selected patient is not defined, use the va matched patient because we are doing this check
; during accept validation
I '$G(SELPAT) S SELPAT=$$GET1^DIQ(52.49,PSOIEN,.05,"I") Q:'$G(SELPAT) 0
I $G(MBMSITE) D
. N DUPPATS,DUP
. D DUPVPAT^PSOERX1E(SELPAT,.DUPPATS) I '$D(DUPPATS) Q
. S ERXMMFLG=2,ERXCNT=ERXCNT+1,ERXMSG(ERXCNT)="The following VistA Patient(s) has been identified as potential duplicate(s):"
. S DUP=0 F S DUP=$O(DUPPATS(DUP)) Q:'DUP S ERXCNT=ERXCNT+1,ERXMSG(ERXCNT)=" "_DUP_"-"_DUPPATS(DUP)
S DFN=SELPAT D DEM^VADPT
; Warning/Block for Patient w/out valid Address (CS prescriptions only)
I $$GET1^DIQ(52.49,ERXIEN,95.1,"I"),'$$VALPTADD^PSOERXUT(SELPAT) D
. S ERXMMFLG=1,ERXCNT=ERXCNT+1,ERXMSG(ERXCNT)="VistA Patient does not have a current mailing or residential address on file."
. S ERXMMFLG=$S(ACTION="EP":2,1:0)
; Checking for ChampVA Eligibility (MBM Sites only)
I $G(MBMSITE),'$$CHVAELIG^PSOERXU9(DFN) D
. S ERXMMFLG=$S(ACTION="EP":2,1:0),ERXCNT=ERXCNT+1,ERXMSG(ERXCNT)="VistA Patient is not eligible for ChampVA Rx Benefit."
; Checking on Allergies/Adverse Reactions
S GMRA="0^0^111" D EN1^GMRADPT I $G(GMRAL)="" D
. S ERXMMFLG=$S(ACTION="EP"!'$G(MBMSITE):2,1:0),ERXCNT=ERXCNT+1,ERXMSG(ERXCNT)="VistA Patient does not have an Allergy Assessment."
;
I $O(ERXMSG(0)) D
. W !!,"*******************************",$S(ERXMMFLG:" WARNING(S) ",1:"INVALID PATIENT"),"*******************************"
. S I=0 F S I=$O(ERXMSG(I)) Q:'I D
. . W !,$G(ERXMSG(I))
. W !,"*****************************************************************************"
;
Q ERXMMFLG
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERX1A 18064 printed Dec 13, 2024@02:28:11 Page 2
PSOERX1A ;ALB/BWF - eRx Utilities/RPC's ; 8/3/2016 5:14pm
+1 ;;7.0;OUTPATIENT PHARMACY;**467,527,508,551,581,617,669,700,743,746**;DEC 1997;Build 106
+2 ;
+3 QUIT
+4 ; select an item
SI ;
+1 NEW RESP,ERXIEN,ERXDAT,LINE,LINEVAR,ERXPAT,ERXLOCK,DIR,NEWRXIEN,REQIEN,MTYPE,Y
+2 DO FULL^VALM1
+3 SET DIR(0)="N^"_VALMBG_":"_VALMLST_":0"
DO ^DIR
+4 IF 'Y
SET VALMBCK="R"
QUIT
+5 SET RESP=Y
+6 SET ERXIEN=$ORDER(@VALMAR@("IDX",RESP,""))
if 'ERXIEN
QUIT
+7 ; Get the patient IEN
+8 SET ERXPAT=$$GETPAT^PSOERXU5(ERXIEN)
+9 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+10 IF 'ERXPAT
IF "IEOE"[MTYPE
DO EN^PSOERX1(ERXIEN)
SET VALMBCK="R"
QUIT
+11 IF '$DATA(PCV)
Begin DoDot:1
+12 SET ERXLOCK=$$L(ERXPAT,1)
+13 IF 'ERXLOCK
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET VALMBCK="R"
QUIT
+14 DO EN^PSOERX1(ERXIEN)
+15 DO UL(ERXPAT)
+16 KILL %
SET VALMBCK="R"
End DoDot:1
QUIT
+17 DO EN^PSOERX1(ERXIEN)
+18 KILL %
+19 SET VALMBCK="R"
+20 QUIT
SBN ;
+1 NEW Y,ERXIEN,ERXPAT,DIR,MTYPE
+2 DO FULL^VALM1
+3 SET Y=+$PIECE(XQORNOD(0),"=",2)
+4 IF 'Y
SET VALMBCK="R"
QUIT
+5 SET ERXIEN=$ORDER(@VALMAR@("IDX",Y,""))
if 'ERXIEN
QUIT
+6 SET ERXPAT=$$GETPAT^PSOERXU5(ERXIEN)
+7 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+8 IF 'ERXPAT
IF "IEOE"[MTYPE
DO EN^PSOERX1(ERXIEN)
SET VALMBCK="R"
QUIT
+9 IF '$DATA(PCV)
Begin DoDot:1
+10 SET ERXLOCK=$$L(ERXPAT,1)
+11 IF 'ERXLOCK
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET VALMBCK="R"
QUIT
+12 DO EN^PSOERX1(ERXIEN)
+13 DO UL(ERXPAT)
+14 SET VALMBCK="R"
KILL %
End DoDot:1
QUIT
+15 DO EN^PSOERX1(ERXIEN)
+16 SET VALMBCK="R"
+17 KILL %
+18 QUIT
L(DFN,DIS,SILENT) ; Locks an eRx Patient
+1 ; Input: DFN - Pointer to eRx Patient (Pointer to #52.46)
+2 ; DIS - Display name of the user currently locking the record
+3 ; (o)SILENT - 1: Silent call - Nothing displayed back | 0: Display information about the Lock on the screen
+4 ;Output: 1 - Record Locked Successfully | 0 - Record already Locked by another user
+5 IF $GET(PSONOLCK)
QUIT 1
+6 NEW FLAG,LKTOUT
SET ^XTMP("PSOERXLOCK",0)=$$PDATE
SET LKTOUT=0
+7 SET LKTOUT=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":0,$GET(DILOCKTM)>0:DILOCKTM,1:3)
+8 ; TEMP CHANGE UNTIL MBM GETS OFF Class 3 option
+9 IF $$GET1^DIQ(59.7,1,102,"I")="MBM"
IF $GET(^XTMP("PSOERXLOCK",DFN))
QUIT 0
+10 ; If a lock is already established for this patient and is associated with the current user
+11 IF $PIECE($GET(^XTMP("PSOERXLOCK",DFN)),"^",1)=DUZ
Begin DoDot:1
+12 LOCK +^XTMP("PSOERXLOCK",DFN):LKTOUT
SET FLAG=$TEST
+13 IF 'FLAG
if '$GET(SILENT)
WRITE !,"You have this patient locked in another open session"
End DoDot:1
QUIT FLAG
+14 IF '$DATA(^XTMP("PSOERXLOCK",DFN))
Begin DoDot:1
+15 LOCK +^XTMP("PSOERXLOCK",DFN):LKTOUT
SET FLAG=$TEST
+16 IF FLAG
Begin DoDot:2
+17 DO NOW^%DTC
SET ^XTMP("PSOERXLOCK",DFN)=DUZ_"^"_%
+18 SET FDA(52.46,DFN_",",6)=DUZ
+19 DO UPDATE^DIE(,"FDA")
KILL FDA
End DoDot:2
End DoDot:1
QUIT FLAG
+20 IF $DATA(^XTMP("PSOERXLOCK",DFN))
QUIT $$R
+21 ;
UL(DFN) ; unlock
+1 IF $GET(PSONOLCK)
QUIT
+2 LOCK -^XTMP("PSOERXLOCK",DFN)
KILL ^XTMP("PSOERXLOCK",DFN)
+3 QUIT
+4 ;
R() ; check lock on node
+1 NEW MBMSITE
+2 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
+3 NEW LKTOUT
SET LKTOUT=$SELECT($GET(MBMSITE):0,$GET(DILOCKTM)>0:DILOCKTM,1:3)
+4 ;if user has same patient already locked, Q 1, will only lock once
+5 IF $PIECE($GET(^XTMP("PSOERXLOCK",DFN)),"^")=DUZ
QUIT 1
+6 LOCK +^XTMP("PSOERXLOCK",DFN):LKTOUT
IF $TEST
Begin DoDot:1
+7 DO NOW^%DTC
SET ^XTMP("PSOERXLOCK",DFN)=DUZ_"^"_%
+8 SET FDA(52.46,DFN_",",6)=DUZ
+9 DO UPDATE^DIE(,"FDA")
KILL FDA
End DoDot:1
QUIT 1
+10 IF $TEST=0
if DIS=1&'$GET(SILENT)
WRITE !,$$WHO(DFN)
SET Y=$PIECE($GET(^XTMP("PSOERXLOCK",DFN)),"^",2)
XECUTE ^DD("DD")
QUIT $SELECT(DIS=0:0_"^"_$PIECE($GET(^VA(200,+$PIECE($GET(^XTMP("PSOERXLOCK",DFN)),"^"),0)),"^")_"^"_Y,1:0)
+11 ;
PDATE() ;
+1 NEW X1,X2
SET X1=DT
SET X2=+14
DO C^%DTC
+2 QUIT X_"^"_DT_"^eRx Pharmacy patient locks"
+3 ;
WHO(DFN) ;
+1 SET Y=$PIECE($GET(^XTMP("PSOERXLOCK",DFN)),"^",2)
XECUTE ^DD("DD")
+2 QUIT $PIECE($GET(^VA(200,+$PIECE($GET(^XTMP("PSOERXLOCK",DFN)),"^"),0)),"^")_" is editing orders for this patient ("_Y_")"
+3 ;
+4 ;
+5 ; TEXT - variable where text is stored (passed by reference)
+6 ; HDR - header text
+7 ; DATA - data associated with the header
+8 ; STRT - start location (column)
+9 ; LEN - total length for header and data
ADDITEM(TEXT,HDR,DATA,STRT,LEN) ;
+1 NEW LLEN,FULLDAT,L
+2 SET FULLDAT=$GET(HDR)_$GET(DATA)
+3 SET TEXT=$GET(TEXT,"")
IF STRT=1
SET TEXT=TEXT_$EXTRACT(FULLDAT,1,LEN)
QUIT
+4 SET LLEN=$LENGTH(TEXT)
+5 IF LLEN<STRT
Begin DoDot:1
+6 FOR L=$LENGTH(TEXT):1:STRT-1
Begin DoDot:2
+7 SET TEXT=TEXT_" "
End DoDot:2
End DoDot:1
+8 SET TEXT=TEXT_$EXTRACT(FULLDAT,1,LEN)
+9 QUIT
+10 ; provider information display
PROV ;
+1 DO FULL^VALM1
IF $$DONOTFIL^PSOERXUT(PSOIEN)
SET VALMBCK="R"
QUIT
+2 NEW STAT,RESVAL
+3 SET RESVAL=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
+4 SET STAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
+5 IF STAT="RXE"
IF '$$RXEPRMT^PSOERXU7(PSOIEN)
QUIT
+6 IF STAT="CXE"
IF (RESVAL="A"!(RESVAL="AWC"))!(RESVAL="V")
IF '$$RXEPRMT^PSOERXU7(PSOIEN)
QUIT
+7 IF '$$GET1^DIQ(52.49,PSOIEN,2.3,"I")
SET XQORM("B")="Edit"
+8 DO EN^PSOERXR1
+9 DO INIT^PSOERSE1
+10 QUIT
+11 ; patient information display
PAT ;
+1 DO FULL^VALM1
IF $$DONOTFIL^PSOERXUT(PSOIEN)
SET VALMBCK="R"
QUIT
+2 NEW STAT,RESVAL
+3 SET RESVAL=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
+4 SET STAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
+5 IF STAT="RXE"
IF '$$RXEPRMT^PSOERXU7(PSOIEN)
QUIT
+6 IF STAT="CXE"
IF (RESVAL="A"!(RESVAL="AWC"))!(RESVAL="V")
IF '$$RXEPRMT^PSOERXU7(PSOIEN)
QUIT
+7 IF '$$GET1^DIQ(52.49,PSOIEN,.05,"I")
SET XQORM("B")="Edit"
+8 DO EN^PSOERXP1
+9 DO INIT^PSOERSE1
+10 QUIT
+11 ; drug information display
DRUG ;
+1 DO FULL^VALM1
IF $$DONOTFIL^PSOERXUT(PSOIEN)
SET VALMBCK="R"
QUIT
+2 NEW STAT,RESVAL
+3 SET RESVAL=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
+4 SET STAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
+5 IF STAT="RXE"
IF '$$RXEPRMT^PSOERXU7(PSOIEN)
QUIT
+6 IF STAT="CXE"
IF (RESVAL="A"!(RESVAL="AWC"))!(RESVAL="V")
IF '$$RXEPRMT^PSOERXU7(PSOIEN)
QUIT
+7 IF '$$GET1^DIQ(52.49,PSOIEN,3.2,"I")
SET XQORM("B")="Edit"
+8 DO EN^PSOERXD1
+9 DO INIT^PSOERSE1
+10 QUIT
+11 ; edit validation
+12 ; EDTYPE - D=drug, P=patient, PR=provider
EDIT(EDTYP,SBN) ;
+1 NEW MBMSITE,DIR,Y,ITEM,RES,TAG,PQUIT,RXSTAT,SUGVARX
+2 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
+3 DO FULL^VALM1
+4 SET SBN=$GET(SBN,"")
+5 SET VALMBCK="R"
+6 if '$GET(PSOIEN)
QUIT
+7 SET RXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
IF RXSTAT="RJ"!(RXSTAT="RM")!(RXSTAT="PR")!($GET(MBMSITE)&($EXTRACT(RXSTAT,1,3)="REM"))
Begin DoDot:1
+8 WRITE !!,"Cannot edit a prescription with a status of 'Rejected', 'Removed',",!,"or 'Processed",!
+9 SET DIR(0)="E"
DO ^DIR
End DoDot:1
QUIT
+10 SET PSOIENS=PSOIEN_","
+11 if '$DATA(EDTYP)
QUIT
+12 IF EDTYP="D"
Begin DoDot:1
+13 SET SUGVARX=$$MATCHSUG^PSOERUT4(PSOIEN)
+14 IF $GET(SUGVARX)
Begin DoDot:2
+15 WRITE !?64,"Updating..."
+16 DO SAVEDRUG^PSOERUT2(PSOIEN,SUGVARX)
+17 KILL @VALMAR
DO INIT^PSOERXD1
SET VALMBCK="R"
+18 HANG .5
WRITE "done."
HANG 1
End DoDot:2
QUIT
+19 WRITE !
+20 DO PLSTRNG(1,10,.RES,SBN)
+21 IF '$ORDER(RES(0))
QUIT
+22 IF $DATA(RES(1))
DO DERX1^PSOERXD2(PSOIEN,PSOIENS)
+23 SET (ITEM,PQUIT)=0
FOR
SET ITEM=$ORDER(RES(ITEM))
if 'ITEM!(PQUIT)
QUIT
Begin DoDot:2
+24 SET TAG="VDRG"_ITEM_"^PSOERXD2(PSOIEN,PSOIENS)"
DO @TAG
End DoDot:2
+25 KILL @VALMAR
DO INIT^PSOERXD1
End DoDot:1
QUIT
+26 IF EDTYP="P"
DO VPAT
KILL @VALMAR
DO INIT^PSOERXP1
QUIT
+27 IF EDTYP="PR"
DO VPROV
KILL @VALMAR
DO INIT^PSOERXR1
QUIT
+28 QUIT
+29 ; edit provider
VPROV ;
+1 NEW MBMSITE,EXPRVIEN,VAPRVIEN,MANVAL,PRVDAT,EXPRNAME,EXPRLNAM,EXPRFNAM,PSOIENS,ERXMMFLG,FDA
+2 NEW EXPRIENS,SELPRV,QUIT,VAPNM,NEWPIEN,VANPI,MTYPE,RESTYPE,ERXSTAT,NEWVAL,DONE,PSOQUIT
+3 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
+4 SET PSOIENS=PSOIEN_","
+5 SET VAPNM=$$GET1^DIQ(52.49,PSOIEN,2.3,"E")
+6 SET EXPRVIEN=$$GET1^DIQ(52.49,PSOIEN,2.1,"I")
+7 SET EXPRIENS=EXPRVIEN_","
+8 DO GETS^DIQ(52.48,EXPRIENS,".01;.02;.03;1.5;1.6","E","PRVDAT")
+9 SET EXPRNAME=$GET(PRVDAT(52.48,EXPRIENS,.01,"E"))
+10 SET EXPRLNAM=$GET(PRVDAT(52.48,EXPRIENS,.02,"E"))
+11 SET EXPRFNAM=$GET(PRVDAT(52.48,EXPRIENS,.03,"E"))
+12 SET MANVAL=$$GET1^DIQ(52.49,PSOIEN,1.3,"I")
+13 SET MTYPE=$$GET1^DIQ(52.49,PSOIEN,.08,"I")
+14 SET VAPIEN=$$GET1^DIQ(52.49,PSOIEN,2.3,"I")
+15 SET RESTYPE=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
+16 SET ERXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
+17 ;
+18 ; There is a Provider currently selected
+19 SET PSOQUIT=0
+20 IF VAPIEN
Begin DoDot:1
+21 KILL DIR
WRITE !,"Current Vista Provider: "_VAPNM,!
+22 SET DIR(0)="YO"
SET DIR("A")="Would you like to edit the Provider"
+23 IF MANVAL
SET DIR("A",1)="This Provider has already been validated."
+24 SET DIR("B")="NO"
DO ^DIR
IF 'Y!$DATA(DIRUT)!$DATA(DIROUT)
SET PSOQUIT=1
QUIT
+25 WRITE !
End DoDot:1
IF PSOQUIT
QUIT
+26 ; Suggesting a VistA Provider
+27 SET NEWPIEN=$$MATCHSUG^PSOERPV1(PSOIEN)
+28 ;
+29 IF '$GET(NEWPIEN)
Begin DoDot:1
+30 KILL DIC
WRITE !
SET DIC=200
SET DIC(0)="QEAM"
SET DIC("A")="VISTA PROVIDER: "
SET DIC("S")="I $$CHKPRV2^PSOERX1A(Y)"
+31 IF $GET(MBMSITE)
SET DIC("W")="D PRVIDS^PSOERPV1"
+32 DO ^DIC
IF Y<0
SET PSOQUIT=1
QUIT
+33 SET NEWPIEN=+Y
+34 DO CMPPRV^PSOERPV1(PSOIEN,NEWPIEN)
+35 SET ERXMMFLG=$$PRVWARN("EP",PSOIEN,NEWPIEN)
+36 SET DIR(0)="Y"
SET DIR("A")="Would you like to use this Provider"
+37 SET DIR("B")=$SELECT($GET(ERXMMFLG):"NO",1:"YES")
DO ^DIR
IF 'Y!$DATA(DIRUT)!$DATA(DIROUT)
SET PSOQUIT=1
QUIT
End DoDot:1
IF PSOQUIT
QUIT
+38 ;
+39 WRITE !?64,"Updating..."
+40 ; Setting the eRx Audit Log
+41 SET NEWVAL(1)=$$GET1^DIQ(200,NEWPIEN,.01)_" (DEA#: "_$PIECE($$VADEA^PSOERXU8(NEWPIEN,PSOIEN),"^",2)_")"
+42 DO AUDLOG^PSOERXUT(+PSOIENS,"PROVIDER",DUZ,.NEWVAL)
+43 ;
+44 ; change existing entry
+45 SET FDA(52.49,PSOIENS,2.3)=NEWPIEN
+46 ; Removing Manual Validation fields
+47 SET FDA(52.49,PSOIENS,1.3)=""
SET FDA(52.49,PSOIENS,1.8)=""
SET FDA(52.49,PSOIENS,1.9)=""
+48 ; If auto-matched, change PROV STAT (AUTO-VAL) #1.2 to 2 (VALIDATED/EDITED)
+49 IF $$GET1^DIQ(52.49,+PSOIENS,1.2,"I")=1
SET FDA(52.49,PSOIENS,1.2)=2
+50 DO FILE^DIE(,"FDA")
+51 ;
+52 ; Updating eRx Status to In Progress
+53 IF MTYPE="N"
DO UPDSTAT^PSOERXU1(PSOIEN,"I")
+54 IF MTYPE="RE"
IF RESTYPE="R"
DO UPDSTAT^PSOERXU1(PSOIEN,"RXI")
QUIT
+55 IF MTYPE="RE"
DO UPDSTAT^PSOERXU1(PSOIEN,"RXW")
+56 IF MTYPE="CX"
DO UPDSTAT^PSOERXU1(PSOIEN,"CXI")
+57 HANG .5
WRITE "done.",$CHAR(7)
HANG 1
+58 QUIT
+59 ;
PRVWARN(ACTION,PSOIEN,VAPIEN) ; Check whether the Provider Select is valid or not
+1 ; Input:(r)ACTION - Ation being peformed ("EP": Edit Provider | "VP": Validate Provider)
+2 ; (r)PSOIEN - Pointer to the ERX HOLDING QUEUE file (#52.49)
+3 ; (r)VAPIEN - Provider -Pointer to the NEW PERSON file (#200)
+4 ;Output: 1 - No Issues Found with Provider Selected | 2 - Issues Found With Provider Select by Ok to to proceed | 0 - Invalid Provider Selection
+5 NEW EXPRVNPI,VANPI,ERXDEA,VADEA,I,ERXMSG,ERXPIEN,EXPRVDEA,ERXDRIEN
+6 SET ERXPIEN=$$GET1^DIQ(52.49,PSOIEN,2.1,"I")
+7 SET ERXDRIEN=+$$GET1^DIQ(52.49,PSOIEN,3.2,"I")
+8 IF '$GET(VAPIEN)
SET VAPIEN=$$GET1^DIQ(52.49,PSOIEN,2.3,"I")
IF '$GET(VAPIEN)
QUIT 0
+9 DO PRDRVAL^PSOERXUT(.ERXMSG,ACTION,PSOIEN,VAPIEN,ERXDRIEN)
+10 IF +ERXMSG
QUIT 1
+11 WRITE !!,"*******************************",$SELECT($PIECE(ERXMSG,"^",2)="W":" WARNING(S) ",1:"INVALID PROVIDER"),"*********************************"
+12 SET I=0
FOR
SET I=$ORDER(ERXMSG(I))
if 'I
QUIT
WRITE !,$PIECE(ERXMSG(I),"^")
+13 WRITE !,"********************************************************************************"
+14 IF $PIECE(ERXMSG,"^",2)="W"
QUIT 2
+15 QUIT 0
CHKPRV2(Y) ;
+1 ;Ref. to ^VA(200 supp. by IA 224
+2 IF '$PIECE($GET(^VA(200,Y,"PS")),U)
QUIT 0
+3 QUIT 1
+4 ; validate drug
+5 ; prompt list or range
+6 ; LOW - lowest number to prompt for
+7 ; HIGH - highest number to prompt for
+8 ; EDIT - returned list of selected values
+9 ; EDIT(n1)=""
+10 ; EDIT(n2)=""
+11 ; EDIT(n3)=""
PLSTRNG(LOW,HIGH,EDIT,SBN) ;
+1 NEW DIR,DONE,DONE2,Y,NUMCHK,NUM,VAL,I,LIST
+2 IF '$GET(LOW)!'$GET(HIGH)
SET LIST=0
QUIT
+3 SET DONE=0
+4 FOR
Begin DoDot:1
+5 IF $$GET1^DIQ(52.49,PSOIEN,3.2,"I")=""
SET Y="A"
+6 IF '$DATA(Y)
IF '$ORDER(^PS(52.49,PSOIEN,21,0))
SET Y="A"
+7 IF SBN']""
IF '$DATA(Y)!($GET(Y)[" ")!($GET(Y)[".")
Begin DoDot:2
+8 SET DIR(0)="FO^"
SET DIR("A")="Which field(s) would you like to edit? ("_LOW_"-"_HIGH_") or 'A'll"
+9 SET DIR("?")="Enter a number, range, or a list of numbers (i.e. 3, 1-5, 3,7,9, or 'A'll)"
+10 SET DIR("B")="A"
+11 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DTOUT)
SET DONE=1
QUIT
+12 IF Y="^"
SET DONE=1
QUIT
End DoDot:2
+13 IF SBN']""
IF Y["-"
IF Y[","
Begin DoDot:2
+14 WRITE !!,"Invalid Response."
+15 WRITE !,"Answer must be numeric (1-10), a series of numbers (3,5,7), 'A' or 'ALL'."
+16 SET DIR(0)="E"
DO ^DIR
KILL Y,DIR
IF $DATA(DIRUT)!$DATA(DTOUT)
SET DONE=1
QUIT
End DoDot:2
QUIT
+17 IF SBN']""
IF (Y[".")!(Y[" ")
Begin DoDot:2
+18 WRITE !!,"Invalid Response."
+19 WRITE !,"Answer must be numeric (1-10), a series of numbers (3,5,7), 'A' or 'ALL'."
+20 SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DTOUT)
SET DONE=1
QUIT
+21 IF Y'[" "
KILL Y
End DoDot:2
QUIT
+22 IF SBN]""
IF '$DATA(Y)
SET Y=SBN
+23 if Y["."
QUIT
+24 IF Y="^"
SET DONE=1
QUIT
+25 SET Y=$$UP^XLFSTR(Y)
+26 IF Y="A"!(Y="ALL")
Begin DoDot:2
+27 FOR I=LOW:1:HIGH
Begin DoDot:3
+28 SET EDIT(I)=""
End DoDot:3
+29 SET DONE=1
End DoDot:2
QUIT
+30 ; check for a range or list of numbers
+31 IF Y'["-"
IF Y'[","
IF Y'<LOW
IF Y'>HIGH
SET EDIT(+Y)=""
SET DONE=1
QUIT
+32 IF Y?1.2N1"-"1.2N
Begin DoDot:2
+33 FOR I=$PIECE(Y,"-"):1:$PIECE(Y,"-",2)
Begin DoDot:3
+34 if I<LOW!(I>HIGH)
QUIT
+35 SET EDIT(I)=""
End DoDot:3
End DoDot:2
+36 IF $DATA(EDIT)
SET DONE=1
QUIT
+37 IF Y[","
Begin DoDot:2
+38 ; check to see if there are alpha-numerics if there are, quit and reprompt
+39 SET NUMCHK=$TRANSLATE(Y,",","")
IF 'NUMCHK
WRITE !,"Invalid response."
QUIT
+40 SET DONE2=0
+41 FOR NUM=1:1
Begin DoDot:3
+42 SET VAL=$PIECE(Y,",",NUM)
+43 IF 'VAL
SET DONE2=1
QUIT
+44 IF VAL<LOW!(VAL>HIGH)
QUIT
+45 SET EDIT(VAL)=""
End DoDot:3
if DONE2
QUIT
End DoDot:2
+46 IF $DATA(EDIT)
SET DONE=1
QUIT
+47 WRITE !,"Invalid Response."
+48 WRITE !,"Answer must be numeric (1-10), a series of numbers (3,5,7), 'A' or 'ALL'."
+49 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL Y,DIR
End DoDot:1
if DONE
QUIT
+50 QUIT
+51 ; Match Patient
VPAT ;
+1 NEW MBMSITE,ERXPIEN,VAPIEN,MANVAL,ERXLNAME,ERXFNAME,DIR,Y,PSOIENS,VAPIEN,MANVAL,DIC,SELPAT,PDONE,DFN,I,VADM
+2 NEW ERXSTAT,RESTYPE,MTYPE,PSOQUIT,FDA,GMRA,GMRAL
+3 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
+4 SET PSOIENS=PSOIEN_","
+5 SET ERXPIEN=$$GET1^DIQ(52.49,PSOIEN,.04,"I")
+6 SET ERXLNAME=$$GET1^DIQ(52.46,ERXPIEN,.02,"E")
+7 SET ERXFNAME=$$GET1^DIQ(52.46,ERXPIEN,.03,"E")
+8 SET VAPIEN=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
+9 SET MANVAL=$$GET1^DIQ(52.49,PSOIEN,1.7,"I")
+10 SET RESTYPE=$$GET1^DIQ(52.49,PSOIEN,52.1)
+11 SET ERXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
+12 SET MTYPE=$$GET1^DIQ(52.49,PSOIEN,.08,"I")
+13 ; There is a patient currently selected
+14 SET PSOQUIT=0
+15 IF VAPIEN
Begin DoDot:1
+16 KILL DIR
WRITE !,"Current Vista patient: "_$$GET1^DIQ(2,VAPIEN,.01,"E"),!
+17 SET DIR(0)="YO"
SET DIR("A")="Would you like to edit the patient"
+18 IF MANVAL
SET DIR("A",1)="This Patient has already been validated."
+19 SET DIR("B")="NO"
DO ^DIR
IF 'Y!$DATA(DIRUT)!$DATA(DIROUT)
SET PSOQUIT=1
QUIT
End DoDot:1
IF PSOQUIT
QUIT
+20 ; Suggesting a VistA Patient
+21 SET SELPAT=$$MATCHSUG^PSOERPT1(PSOIEN)
+22 ;
+23 IF '$GET(SELPAT)
Begin DoDot:1
+24 KILL DIC,DIR
WRITE !
SET DIC=2
SET DIC(0)="QEAM"
SET DIC("A")="VISTA PATIENT: "
SET DIC("S")="I '$$DEAD^PSONVARP(Y)"
+25 IF $GET(MBMSITE)
SET DIC("W")="D PATIDS^PSOERPT1"
+26 DO ^DPTLK
IF Y<0
SET PSOQUIT=1
QUIT
+27 SET SELPAT=+Y
+28 DO CMPPAT^PSOERPT1(PSOIEN,SELPAT)
+29 SET ERXMMFLG=$$PATWARN("EP",PSOIEN,SELPAT)
+30 SET DIR(0)="Y"
SET DIR("A")="Would you like to use this patient"
+31 SET DIR("B")=$SELECT($GET(ERXMMFLG):"NO",1:"YES")
DO ^DIR
IF 'Y!$DATA(DIRUT)!$DATA(DIROUT)
SET PSOQUIT=1
QUIT
End DoDot:1
IF PSOQUIT
QUIT
+32 ;
+33 WRITE !?64,"Updating..."
+34 ;Setting the eRx Audit Log
+35 SET DFN=SELPAT
DO DEM^VADPT
+36 NEW NEWVAL
SET NEWVAL(1)=$$GET1^DIQ(2,SELPAT,.01)_" (L4SSN: "_$PIECE($PIECE(VADM(2),"^",2),"-",3)_" | DOB: "_$PIECE(VADM(3),"^",2)_")"
+37 DO AUDLOG^PSOERXUT(+PSOIENS,"PATIENT",DUZ,.NEWVAL)
+38 ;
+39 ;Updating eRx Record w/ New Patient
+40 SET FDA(52.49,PSOIENS,.05)=SELPAT
+41 SET FDA(52.49,PSOIENS,1.7)=""
SET FDA(52.49,PSOIENS,1.13)=""
SET FDA(52.49,PSOIENS,1.14)=""
+42 ; If auto-matched, change PAT STATUS (AUTO-VAL) #1.6 to 2 (VALIDATED/EDITED)
+43 IF $$GET1^DIQ(52.49,+PSOIENS,1.6,"I")=1
SET FDA(52.49,PSOIENS,1.6)=2
+44 DO FILE^DIE(,"FDA")
+45 ;
+46 ; VistA Patient ChampVA Eligibility Check (MbM Only)
+47 IF $GET(MBMSITE)
IF '$$CHVAELIG^PSOERXU9(SELPAT)
Begin DoDot:1
+48 IF ",N,I,W,RXI,RXN,RXW,RXR,CXI,CXN,CXW,"[(","_$GET(ERXSTAT)_",")
Begin DoDot:2
+49 DO UPDSTAT^PSOERXU1(PSOIEN,"HEL","Hold due to Eligibility Issue")
+50 WRITE !!,"This eRx has been put on Hold (HEL) because the VistA Patient ("_$$GET1^DIQ(2,SELPAT,.01)_") is not Eligible for ChampVA Rx Benefit."
+51 KILL DIR
DO PAUSE^VALM1
End DoDot:2
+52 DO AUTOHOLD^PSOERX1E("E",PSOIEN,SELPAT)
End DoDot:1
QUIT
+53 ;
+54 ;VistA Patient Allergy Check (MbM Only)
+55 IF $GET(MBMSITE)
Begin DoDot:1
+56 SET DFN=SELPAT
SET GMRA="0^0^111"
DO EN1^GMRADPT
IF $GET(GMRAL)'=""
QUIT
+57 IF ",N,I,W,RXI,RXN,RXW,RXR,CXI,CXN,CXW,"[(","_$GET(ERXSTAT)_",")
Begin DoDot:2
+58 DO UPDSTAT^PSOERXU1(PSOIEN,"HAL","Hold for Allergy Assessment")
+59 WRITE !!,"This eRx has been put on Hold (HAL) because the VistA Patient ("_$$GET1^DIQ(2,SELPAT,.01)_") does not have an Allergy Assessment.."
+60 KILL DIR
DO PAUSE^VALM1
End DoDot:2
+61 DO AUTOHOLD^PSOERX1E("A",PSOIEN,SELPAT)
End DoDot:1
IF $GET(GMRAL)=""
QUIT
+62 ;
+63 ;Updating eRx Status to In Progress
+64 IF MTYPE="N"
DO UPDSTAT^PSOERXU1(PSOIEN,"I")
+65 IF MTYPE="RE"
DO UPDSTAT^PSOERXU1(PSOIEN,"RXI")
+66 IF MTYPE="CX"
DO UPDSTAT^PSOERXU1(PSOIEN,"CXI")
+67 IF MTYPE="RE"
DO UPDSTAT^PSOERXU1(PSOIEN,"RXI")
+68 IF MTYPE="CX"
DO UPDSTAT^PSOERXU1(PSOIEN,"CXI")
+69 IF ERXSTAT="N"
DO UPDSTAT^PSOERXU1(PSOIEN,"I")
+70 HANG .5
WRITE "done.",$CHAR(7)
HANG 1
+71 QUIT
+72 ;
PATWARN(ACTION,PSOIEN,SELPAT) ; Check whether the Patient Select is valid or not
+1 ; Input:(r)ACTION - Ation being peformed ("EP": Edit Patient | "VP": Validate Patient)
+2 ; (r)PSOIEN - Pointer to the ERX HOLDING QUEUE file (#52.49)
+3 ; (r)SELPAT - Patient -Pointer to the PATIENT file (#2)
+4 ;Output: 1 - No Issues Found with Patient Selected | 2 - Issues Found With Patient selected but Ok to proceed | 0 - Invalid Patient Selection
+5 NEW MBMSITE,ERXPIEN,ERXSSN,ERXDOB,ERXGEN,ERXMMFLG,ERXMSG,EXPRVDEA,ERXCNT,I,VADM,GMRA,GMRAL
+6 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
+7 SET ERXCNT=0
SET ERXMMFLG=1
+8 SET ERXPIEN=$$GET1^DIQ(52.49,PSOIEN,.04,"I")
+9 SET ERXSSN=$$GET1^DIQ(52.46,ERXPIEN,1.4,"E")
SET ERXSSN=$TRANSLATE(ERXSSN,"-","")
+10 SET ERXDOB=$$GET1^DIQ(52.46,ERXPIEN,.08,"I")
+11 SET ERXGEN=$$GET1^DIQ(52.46,ERXPIEN,.07,"I")
+12 ; if the selected patient is not defined, use the va matched patient because we are doing this check
+13 ; during accept validation
+14 IF '$GET(SELPAT)
SET SELPAT=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
if '$GET(SELPAT)
QUIT 0
+15 IF $GET(MBMSITE)
Begin DoDot:1
+16 NEW DUPPATS,DUP
+17 DO DUPVPAT^PSOERX1E(SELPAT,.DUPPATS)
IF '$DATA(DUPPATS)
QUIT
+18 SET ERXMMFLG=2
SET ERXCNT=ERXCNT+1
SET ERXMSG(ERXCNT)="The following VistA Patient(s) has been identified as potential duplicate(s):"
+19 SET DUP=0
FOR
SET DUP=$ORDER(DUPPATS(DUP))
if 'DUP
QUIT
SET ERXCNT=ERXCNT+1
SET ERXMSG(ERXCNT)=" "_DUP_"-"_DUPPATS(DUP)
End DoDot:1
+20 SET DFN=SELPAT
DO DEM^VADPT
+21 ; Warning/Block for Patient w/out valid Address (CS prescriptions only)
+22 IF $$GET1^DIQ(52.49,ERXIEN,95.1,"I")
IF '$$VALPTADD^PSOERXUT(SELPAT)
Begin DoDot:1
+23 SET ERXMMFLG=1
SET ERXCNT=ERXCNT+1
SET ERXMSG(ERXCNT)="VistA Patient does not have a current mailing or residential address on file."
+24 SET ERXMMFLG=$SELECT(ACTION="EP":2,1:0)
End DoDot:1
+25 ; Checking for ChampVA Eligibility (MBM Sites only)
+26 IF $GET(MBMSITE)
IF '$$CHVAELIG^PSOERXU9(DFN)
Begin DoDot:1
+27 SET ERXMMFLG=$SELECT(ACTION="EP":2,1:0)
SET ERXCNT=ERXCNT+1
SET ERXMSG(ERXCNT)="VistA Patient is not eligible for ChampVA Rx Benefit."
End DoDot:1
+28 ; Checking on Allergies/Adverse Reactions
+29 SET GMRA="0^0^111"
DO EN1^GMRADPT
IF $GET(GMRAL)=""
Begin DoDot:1
+30 SET ERXMMFLG=$SELECT(ACTION="EP"!'$GET(MBMSITE):2,1:0)
SET ERXCNT=ERXCNT+1
SET ERXMSG(ERXCNT)="VistA Patient does not have an Allergy Assessment."
End DoDot:1
+31 ;
+32 IF $ORDER(ERXMSG(0))
Begin DoDot:1
+33 WRITE !!,"*******************************",$SELECT(ERXMMFLG:" WARNING(S) ",1:"INVALID PATIENT"),"*******************************"
+34 SET I=0
FOR
SET I=$ORDER(ERXMSG(I))
if 'I
QUIT
Begin DoDot:2
+35 WRITE !,$GET(ERXMSG(I))
End DoDot:2
+36 WRITE !,"*****************************************************************************"
End DoDot:1
+37 ;
+38 QUIT ERXMMFLG
