ORDEA ;ISL/TC & JMH & JLC - DEA related items ;07/10/19 09:22
;;3.0;ORDER ENTRY/RESULTS REPORTING;**306,374,377,499,607**;Dec 17, 1997;Build 7
;
;Reference to ^PSSOPKI supported by DBIA #3737
;Reference to ^PSSUTLA1 supported by DBIA #3373
;
;
DEATEXT(ORY) ;returns the mandatory dea text to show when a user checks a controlled substance order to be signed on the signature dialog
N I,ORTY
D GETWP^XPAR(.ORTY,"SYS","OR DEA TEXT")
S I=0 F S I=$O(ORTY(I)) Q:'I S ORY(I)=ORTY(I,0)
Q
;
CSVALUE(ORY,ORID) ;return 1 if the order (ORID) is a controlled substance, 0 for non-controlled substance
N OROI,ORPSTYPE,ORRXDG
S ORY=0,ORPSTYPE=""
S OROI=$$OI^ORQOR2(+ORID)
S ORRXDG=$$DGRX^ORQOR2(+ORID)
I ORRXDG="UNIT DOSE MEDICATIONS" S ORPSTYPE="I"
I ORRXDG="INPATIENT MEDICATIONS" S ORPSTYPE="I"
I ORRXDG="IV MEDICATIONS" S ORPSTYPE="I"
I ORRXDG="OUTPATIENT MEDICATIONS" S ORPSTYPE="O"
I ORRXDG="PHARMACY" S ORPSTYPE="O"
Q:ORPSTYPE=""
D CSCHECK(.ORY,OROI,ORPSTYPE)
S ORY=+ORY
Q
;
PNDHLD(ORY,ORID) ;return 1 if the order is pending a HOLD, 0 otherwise
S ORY=0
N ORLSTACT S ORLSTACT=$O(^OR(100,+ORID,8,"A"),-1)
I $P(^OR(100,+ORID,8,ORLSTACT,0),U,2)="HD" S ORY=1
Q
;
CSCHECK(ORCSVAL,OROI,ORPSTYPE) ; return 1 if OI is a controlled substance, 0 for non-controlled substance
;ORCSVAL=1:controlled substance, 0:non-controlled substance
;OROI=OR orderable item
;ORPSTYPE="O":Outpatient pharmacy order, "I" or "U":Inpatient med order
N ORPSOI,ORTPKG,ORDEAFLG,ORDETOX
S ORCSVAL=0_U_0,ORTPKG=$P($G(^ORD(101.43,+$G(OROI),0)),U,2)
I ORPSTYPE="I" Q
Q:ORTPKG'["PS"
S ORPSOI=+ORTPKG Q:ORPSOI'>0
I '$L($T(OIDEA^PSSUTLA1)) Q
S ORDEAFLG=+$$OIDEA^PSSOPKI(ORPSOI,ORPSTYPE)
I ORDEAFLG'>0 S ORCSVAL=0
I ORDEAFLG>0 S ORCSVAL=1
S ORDETOX=0
;get detox value either from OIDEA^PSSUTLA1 or from different api or method
S ORDETOX=$$OIDETOX^PSSOPKI(ORPSOI,ORPSTYPE)
S ORCSVAL=ORCSVAL_U_ORDETOX
Q
SIGINFO(ORY,ORDFN,ORPROV,OROID) ;returns the provider/patient info that must be displayed when signing controlled substance orders
N ORI S ORI=0
;patient name
S ORI=ORI+1,ORY(ORI)=$P(^DPT(+ORDFN,0),U)
;date of issuance
S ORI=ORI+1,ORY(ORI)="Date of Issuance: "_$$FMTE^XLFDT($$DT^XLFDT)
;provider name
S ORI=ORI+1,ORY(ORI)="Provider: "_$$GET1^DIQ(200,ORPROV,.01,"E")
;provider address (facility address)
N ORINST
D GETS^DIQ(4,DUZ(2),".01;.02;1.01;1.02;1.03;1.04","E","ORINST")
N ORADDNUM S ORADDNUM=0
I $L(ORINST(4,DUZ(2)_",",1.01,"E"))>0 S ORI=ORI+1,ORY(ORI)=ORINST(4,DUZ(2)_",",1.01,"E"),ORADDNUM=ORADDNUM+1
I $L(ORINST(4,DUZ(2)_",",1.02,"E"))>0 S ORI=ORI+1,ORY(ORI)=ORINST(4,DUZ(2)_",",1.02,"E"),ORADDNUM=ORADDNUM+1
I $L(ORINST(4,DUZ(2)_",",1.03,"E"))>0 S ORI=ORI+1,ORY(ORI)=ORINST(4,DUZ(2)_",",1.03,"E"),ORADDNUM=ORADDNUM+1
I $L(ORINST(4,DUZ(2)_",",.02,"E"))>0 S ORY(ORI)=ORY(ORI)_", "_ORINST(4,DUZ(2)_",",.02,"E"),ORADDNUM=ORADDNUM+1
I $L(ORINST(4,DUZ(2)_",",1.04,"E"))>0 S ORY(ORI)=ORY(ORI)_" "_ORINST(4,DUZ(2)_",",1.04,"E"),ORADDNUM=ORADDNUM+1
I ORADDNUM=0 D
.S ORI=ORI+1,ORY(ORI)="No Address on record"
.I $L(ORINST(4,DUZ(2)_",",.01,"E"))>0 S ORI=ORI+1,ORY(ORI)="for "_ORINST(4,DUZ(2)_",",.01,"E")
;dea #
S ORI=ORI+1,ORY(ORI)="DEA: "_$$DEA^XUSER(,ORPROV)
;*506
I $G(OROID) S OROID=+OROID I $P($G(^OR(100,OROID,11.1)),U)]"" S ORY(ORI)="DEA: "_$P(^OR(100,OROID,11.1),U)
;detox #
N ORDETOX S ORDETOX="" ; $$DETOX^XUSER(ORPROV) / P607-Remove Detox/X-Waiver
I $L(ORDETOX)>0 S ORI=ORI+1,ORY(ORI)="Detox: "_ORDETOX
Q
HASHINFO(ORY,ORDFN,ORPROV,OROID) ;basic data for all orders getting signed
N ORI S ORI=0
;patient name
S ORI=ORI+1,ORY(ORI)="PatientName:"_$P(^DPT(+ORDFN,0),U)
;patient address
N VAPA,DFN,ORPATADD
S DFN=ORDFN
D ADD^VADPT
S ORPATADD=VAPA(1)_U_VAPA(2)_U_VAPA(3)_U_VAPA(4)_U_$P(VAPA(5),"^")_U_$P(VAPA(5),"^",2)_U_VAPA(6)_U_VAPA(7)
S ORI=ORI+1,ORY(ORI)="PatientAddress:"_ORPATADD
;date of issuance
S ORI=ORI+1,ORY(ORI)="IssuanceDate:"_$$FMTE^XLFDT($$DT^XLFDT)
S ORI=ORI+1,ORY(ORI)="IssuanceInt:"_$$DT^XLFDT
;provider name
S ORI=ORI+1,ORY(ORI)="ProviderName:"_$$GET1^DIQ(200,ORPROV,.01,"E")
S ORI=ORI+1,ORY(ORI)="ProviderNumber:"_ORPROV
;provider address (facility address)
N ORINST
D GETS^DIQ(4,DUZ(2),".01;.02;1.01;1.02;1.03;1.04","E","ORINST")
S ORI=ORI+1,ORY(ORI)="ProviderAddress:"_ORINST(4,DUZ(2)_",",1.01,"E")_U_ORINST(4,DUZ(2)_",",1.02,"E")_U_ORINST(4,DUZ(2)_",",1.03,"E")_U_ORINST(4,DUZ(2)_",",.02,"E")_U_ORINST(4,DUZ(2)_",",1.04,"E")
S ORI=ORI+1,ORY(ORI)="ProviderAdd1:"_ORINST(4,DUZ(2)_",",.01,"E")
;dea #
S ORI=ORI+1,ORY(ORI)="DeaNumber:"_$$DEA^XUSER(,ORPROV)
;*499 - DEA# from backdoor pharmacy or from CPRS order entry
S OROID=+$G(OROID) N ORSLDEA S ORSLDEA=""
I OROID,$P($G(^OR(100,OROID,11.1)),U)]"" S ORSLDEA=$P(^OR(100,OROID,11.1),U)
I ORSLDEA="",$P($G(RXE),"|",14)]"" S ORSLDEA=$P($G(RXE),"|",14)
I ORSLDEA]"" S ORI=ORI+1,ORY(ORI)="DeaNumber:"_ORSLDEA
I ORSLDEA="" S ORI=ORI+1,ORY(ORI)="DeaNumber:"_$$DEA^XUSER(,ORPROV)
;detox #
N ORDETOX S ORDETOX="" ;$$DETOX^XUSER(ORPROV) / P607-Remove Detox/X-Waiver
I $L(ORDETOX)>0 S ORI=ORI+1,ORY(ORI)="DetoxNumber:"_ORDETOX
Q
ORDHINFO(ORY,ORIFN,HASH,OHINFO) ;
N IENS
D BUILDFDA(ORIFN,.ORDFDA,.ORY,$G(HASH),.OHINFO)
Q
BUILDFDA(ORIFN,ORDFDA,OROUT,HASH,OHD) ;
;ORIFN is the CPRS order number to use
;returns 0 if not successful, 1 if successful
N ERROR,ORDIALOG,A,PIEN,DFN,S1,DOSE,SCHED,ROUTE,I
N CONJ,INSTR,SCHED,DUR,DOSE,VADM
I $G(ORIFN)="" Q 0
K ^TMP($J,"ORDEA")
S ORDIALOG=$$GET1^DIQ(100,ORIFN_",",2,"I") I ORDIALOG="" Q 0
D GETDLG^ORCD(+ORDIALOG),GETORDER^ORCD("^OR(100,"_ORIFN_",4.5)")
S INSTR=$$PTR("INSTRUCTIONS"),SCHED=$$PTR("SCHEDULE"),DUR=$$PTR("DURATION"),DOSE=$$PTR("DOSE")
S CONJ=$$PTR("AND/THEN"),ROUTE=$$PTR("ROUTE")
S IENS="+1,"
F I=1:1 Q:'$D(OHD(I)) D
. I $G(OHD(I))["IssuanceInt" S ORDFDA(101.52,IENS,4)=$P(OHD(I),":",2,99) Q
. I $G(OHD(I))["ProviderNumber" S ORDFDA(101.52,IENS,31)=$P(OHD(I),":",2,99) Q
. I $G(OHD(I))["ProviderName" S ORDFDA(101.52,IENS,12)=$P(OHD(I),":",2,99) Q
. I $G(OHD(I))["DeaNumber" S ORDFDA(101.52,IENS,10)=$P(OHD(I),":",2,99) Q
. I $G(OHD(I))["DetoxNumber" S ORDFDA(101.52,IENS,11)=$P(OHD(I),":",2,99) Q
. I $G(OHD(I))["ProviderAdd1" S ORDFDA(101.52,IENS,13)=$P(OHD(I),":",2,99) Q
. I $G(OHD(I))["ProviderAddress" D
.. S A=$P(OHD(I),":",2,99)
.. S ORDFDA(101.52,IENS,14)=$P(A,"^"),ORDFDA(101.52,IENS,15)=$P(A,"^",2)
.. S ORDFDA(101.52,IENS,16)=$P(A,"^",3),ORDFDA(101.52,IENS,17)=$P(A,"^",4)
.. S ORDFDA(101.52,IENS,17.5)=$P(A,"^",5)
. I $G(OHD(I))["PatientAddress" D
.. S A=$P(OHD(I),":",2,99)
.. S ORDFDA(101.52,IENS,21)=$P(A,"^"),ORDFDA(101.52,IENS,22)=$P(A,"^",2),ORDFDA(101.52,IENS,24)=$P(A,"^",3)
.. S ORDFDA(101.52,IENS,25)=$P(A,"^",4),ORDFDA(101.52,IENS,26)=$P(A,"^",6),ORDFDA(101.52,IENS,27)=$P(A,"^",7)
S ORDFDA(101.52,IENS,.01)=ORIFN
S A=$P($G(ORDIALOG("B","DISPENSE DRUG")),"^",2),PIEN=$G(ORDIALOG(A,1)) D
. I PIEN="" S OROUT(1)="DrugName:" Q
. D DATA^PSS50(PIEN,"","","","","ORDEA")
. S ORDFDA(101.52,IENS,6)=^TMP($J,"ORDEA",PIEN,.01),ORDFDA(101.52,IENS,29)=PIEN,ORDFDA(101.52,IENS,30)=^TMP($J,"ORDEA",PIEN,3)
. S OROUT(1)="DrugName:"_^TMP($J,"ORDEA",PIEN,.01)
S INSTR=$O(^ORD(101.41,"AB","OR GTX INSTRUCTIONS",0))
S A=$P($G(ORDIALOG("B","QUANTITY")),"^",2),ORDFDA(101.52,IENS,8)=$G(ORDIALOG(A,1))
S OROUT(2)="Quantity:"_$G(ORDIALOG(A,1))
S A=$P($G(ORDIALOG("B","REFILLS")),"^",2),ORDFDA(101.52,IENS,28)=$G(ORDIALOG(A,1))
S S1=0 F I=1:1 Q:'$D(ORDIALOG(INSTR,I)) D
. S A=$P($G(ORDIALOG(DOSE,I)),"&",1,6)_"|"_$G(ORDIALOG(SCHED,I))_"|"_$$DUR($G(ORDIALOG(DUR,I)))_"|"_$$CONJ($G(ORDIALOG(CONJ,I)))_"|"_$G(ORDIALOG(ROUTE,I))
. S ORDFDA(101.529,"+"_(I+1)_","_IENS,.01)=A
. I '$D(OROUT(3)) S OROUT(3)="Directions:"_A
. E S OROUT(3)=OROUT(3)_A
S A=+$$GET1^DIQ(100,ORIFN_",",6,"I"),A=$$GET1^DIQ(44,A,3,"I")
S DFN=+$$GET1^DIQ(100,ORIFN_",",.02,"I"),A=$$GETICN^MPIF001(DFN),ORDFDA(101.52,IENS,20)=$S(A["^":"",1:A)
D DEM^VADPT S ORDFDA(101.52,IENS,18)=VADM(1),ORDFDA(101.52,IENS,19)=DFN
S ORDFDA(101.52,IENS,2)=$G(HASH)
Q
BUILD(ORIFN) ;Build ARCHIVE entry for CPRS order number
N ORDFDA,OROUT,ERROR
D BUILDFDA(ORIFN,.ORDFDA,.OROUT)
D UPDATE^DIE("","ORDFDA","ORIEN","ERROR")
Q 1
SUBSCRIB(ORIFN,RXN) ;API for Pharmacy to subscribe to an archive entry
;ORIFN is the CPRS order number of the archive Pharmacy wants to use
;RXN is the Pharmacy prescription number that is subscribing to the archive
;returns a 0 if not successful
;returns a 1 if successful
N A,IEN,ORDFDA,ERROR
I $G(ORIFN)=""!($G(RXN)="") Q 0
S IEN=$$FIND1^DIC(101.52,"","MXQ",ORIFN,"","","ERR")
I 'IEN Q 0
S A=$$GET1^DIQ(101.52,IEN_",",1,"I") I A]"",A'=RXN Q 0
S ORDFDA(101.52,IEN_",",1)=RXN
D FILE^DIE("","ORDFDA","ERROR")
I $D(ERROR) Q 0
Q 1
ARCHIVE(ORIFN) ;retrieve archive for specified order number
;ORIFN is the CPRS order number whose archive is requested
I $G(ORIFN)="" Q
K ^TMP($J,"ORDEA",ORIFN) N IEN,ERROR,ORDEA,A,I,S1
S IEN=$$FIND1^DIC(101.52,"","MXQ",ORIFN,"","","ERR")
I 'IEN Q
S IEN=IEN_","
D GETS^DIQ(101.52,IEN,"**","IE","ORDEA","ERROR") I $D(ERROR) Q
S A(1)="" F I=1,4,6,29,30,8,28 S A(1)=A(1)_$G(ORDEA(101.52,IEN,I,"I"))_"^"
S A(1)=$P(A(1),"^",1,7)
S A(2)="" F I=10,11,12,31 S A(2)=A(2)_$G(ORDEA(101.52,IEN,I,"I"))_"^"
S A(2)=$P(A(2),"^",1,4)
S A(3)="" F I=13,14,15,16,17,17.5 S A(3)=A(3)_$G(ORDEA(101.52,IEN,I,"I"))_"^"
S A(3)=$P(A(3),"^",1,6)
S A(4)="" F I=18,19,20 S A(4)=A(4)_$G(ORDEA(101.52,IEN,I,"I"))_"^"
S A(4)=$P(A(4),"^",1,3)
S A(5)="" F I=21,22,24,25,26,27 S A(5)=A(5)_$G(ORDEA(101.52,IEN,I,"I"))_"^"
S A(5)=$P(A(5),"^",1,6)
F I=1:1:5 S ^TMP($J,"ORDEA",ORIFN,I)=A(I)
S S1=0 F S S1=$O(ORDEA(101.529,S1)) Q:'S1 S ^TMP($J,"ORDEA",ORIFN,6,$P(S1,","))=ORDEA(101.529,S1,.01,"I")
Q
HASHRTN(ORIFN) ;returns hash of a specified archive entry
;ORIFN is the CPRS order number for the archive
N IEN,ORHASH,ERR,ERROR
S IEN=$$FIND1^DIC(101.52,"","MXQ",ORIFN,"","","ERR")
I 'IEN Q 0
S IEN=IEN_","
S ORHASH=$$GET1^DIQ(101.52,IEN,2,"I","","ERROR") I $D(ERROR) Q 0
Q ORHASH
BACKDOOR(ORIFN,ORPROV,ORD) ;create archive for new backdoor order
;called from ORMPS
N DFN,OHD,OUT,ORDFDA,PIEN,A,ORSCHED,S1
K ^TMP($J,"ORDEAB")
Q:$G(ORIFN)="" I '$D(^OR(100,ORIFN,0)) Q
I $P($G(^ORD(101.41,+ORD,0)),"^")'="PSO OERR" Q
S S1=0 F S S1=$O(ORD(S1)) Q:'S1 I $P(ORD(S1),"^",2)["DRUG" S PIEN=$G(ORD(S1,1)) I PIEN]"" Q
I $G(PIEN)="" Q
D DATA^PSS50(PIEN,"","","","","ORDEAB") S ORSCHED=$G(^TMP($J,"ORDEAB",PIEN,3))
I ORSCHED'?1N.E Q
I ",2,3,4,5,"'[$E(ORSCHED) Q
S DFN=+$P($G(^OR(100,ORIFN,0)),"^",2)
D HASHINFO(.OHD,DFN,ORPROV)
D BUILDFDA(ORIFN,.ORDFDA,.OUT,"",.OHD)
S ORDFDA(101.52,IENS,1)=$G(^OR(100,ORIFN,4))
D UPDATE^DIE("","ORDFDA","","ERROR")
Q
PINLKCHK(ORY) ;check if the current user has an active PIN lock
;ORY=1 if there is an active lock and ORY=0 if no active lock
S ORY=0
Q:'$D(^XTMP("OR DEA PIN LOCK",DUZ))
N ORDIFF
S ORDIFF=$$FMDIFF^XLFDT($$NOW^XLFDT,$G(^XTMP("OR DEA PIN LOCK",DUZ)),2)
;CHECK IF LOCK IS LESS THAN 15 MINUTES OLD
I ORDIFF<900 S ORY=1
Q
PINLKSET(ORY) ;set a PIN lock on the current user
S ^XTMP("OR DEA PIN LOCK",0)=$$FMADD^XLFDT($$NOW^XLFDT,2)_U_$$NOW^XLFDT
S ^XTMP("OR DEA PIN LOCK",DUZ)=$$NOW^XLFDT
S ORY=^XTMP("OR DEA PIN LOCK",DUZ)
Q
LNKMSG(ORY) ;message to display after successful PIV link for admin contact person
N I,ORTY
D GETWP^XPAR(.ORTY,"DIV^SYS^PKG","OR DEA PIV LINK MSG")
S I=0 F S I=$O(ORTY(I)) Q:'I S ORY(I)=ORTY(I,0)
Q
PTR(NAME) ; -- Returns ptr value of prompt in Dialog file
Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
DUR(DUR) ;
Q $S(DUR="":"",DUR=0:"",1:$E($P(DUR," ",2))_+DUR)
CONJ(CNJ) ;
Q $S(CNJ="":"",CNJ'="T":CNJ,1:"S")
;
AUINTENT(ORY,ORIFN,ORSTATE) ; Audit 'intention to sign' CS ePCS Order
;
; ZEXCEPT: DILOCKTM
N ORFDA
;
S ORY=0
I '$G(ORIFN) Q
S ORIFN=+ORIFN
I '$D(^OR(100,ORIFN,0)) Q
I $G(ORSTATE)'?1(1"1",1"0") Q
S ORY=1
;
S ORFDA(101.51,"?+1,",.01)=ORIFN
S ORFDA(101.511,"+2,?+1,",.01)=$$NOW^XLFDT
S ORFDA(101.511,"+2,?+1,",.02)=DUZ
S ORFDA(101.511,"+2,?+1,",.03)=ORSTATE
L +^ORD(101.51,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
D UPDATE^DIE("","ORFDA")
L -^ORD(101.51,0)
D CLEAN^DILF
;
Q
;
AUDORDXX(ORIFN) ;Audit change to unsigned CS ePCS Order
;
; ZEXCEPT: DILOCKTM
N DFN,ORARR,ORAUDFDA,ORAUDIT,ORDFDA,ORFIELD,ORFILE,ORHASHINFO,ORLN,ORPROV
;
I '$G(ORIFN) Q
S ORIFN=+ORIFN
;
S ORAUDFDA(101.51,"?+1,",.01)=ORIFN
S ORAUDFDA(101.511,"+2,?+1,",.01)=$$NOW^XLFDT
S ORAUDFDA(101.511,"+2,?+1,",.02)=DUZ
;
; Set up ORAUDIT with fields that need to be audited.
; We want to audit the same fields that are being archived to 101.52.
S DFN=+$P($G(^OR(100,ORIFN,0)),U,2)
S ORPROV=$P($G(^OR(100,ORIFN,8,1,0)),U,3)
I 'ORPROV S ORPROV=DUZ
D HASHINFO(.ORHASHINFO,DFN,ORPROV)
D ORDHINFO(,ORIFN,,.ORHASHINFO)
; Convert ORDFDA (generated by ORDHINFO) into word-processing array (ORAUDIT) that we can log to 101.51
S ORLN=0
S ORARR="ORDFDA"
F S ORARR=$Q(@ORARR) Q:ORARR="" Q:$QS(ORARR,0)'="ORDFDA" D
. S ORFILE=$QS(ORARR,1)
. S ORFIELD=$QS(ORARR,3)
. I 'ORFILE!('ORFIELD) Q
. I ORFILE="101.52",((ORFIELD=".01")!(ORFIELD=2)) Q
. S ORLN=ORLN+1
. S ORAUDIT(ORLN)=$$GET1^DID(ORFILE,ORFIELD,,"LABEL")_": "_$G(@ORARR)
I $D(ORAUDIT) S ORAUDFDA(101.511,"+2,?+1,",1)="ORAUDIT"
;
L +^ORD(101.51,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
D UPDATE^DIE("","ORAUDFDA")
L -^ORD(101.51,0)
D CLEAN^DILF
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORDEA 13583 printed Nov 22, 2024@17:39:51 Page 2
ORDEA ;ISL/TC & JMH & JLC - DEA related items ;07/10/19 09:22
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**306,374,377,499,607**;Dec 17, 1997;Build 7
+2 ;
+3 ;Reference to ^PSSOPKI supported by DBIA #3737
+4 ;Reference to ^PSSUTLA1 supported by DBIA #3373
+5 ;
+6 ;
DEATEXT(ORY) ;returns the mandatory dea text to show when a user checks a controlled substance order to be signed on the signature dialog
+1 NEW I,ORTY
+2 DO GETWP^XPAR(.ORTY,"SYS","OR DEA TEXT")
+3 SET I=0
FOR
SET I=$ORDER(ORTY(I))
if 'I
QUIT
SET ORY(I)=ORTY(I,0)
+4 QUIT
+5 ;
CSVALUE(ORY,ORID) ;return 1 if the order (ORID) is a controlled substance, 0 for non-controlled substance
+1 NEW OROI,ORPSTYPE,ORRXDG
+2 SET ORY=0
SET ORPSTYPE=""
+3 SET OROI=$$OI^ORQOR2(+ORID)
+4 SET ORRXDG=$$DGRX^ORQOR2(+ORID)
+5 IF ORRXDG="UNIT DOSE MEDICATIONS"
SET ORPSTYPE="I"
+6 IF ORRXDG="INPATIENT MEDICATIONS"
SET ORPSTYPE="I"
+7 IF ORRXDG="IV MEDICATIONS"
SET ORPSTYPE="I"
+8 IF ORRXDG="OUTPATIENT MEDICATIONS"
SET ORPSTYPE="O"
+9 IF ORRXDG="PHARMACY"
SET ORPSTYPE="O"
+10 if ORPSTYPE=""
QUIT
+11 DO CSCHECK(.ORY,OROI,ORPSTYPE)
+12 SET ORY=+ORY
+13 QUIT
+14 ;
PNDHLD(ORY,ORID) ;return 1 if the order is pending a HOLD, 0 otherwise
+1 SET ORY=0
+2 NEW ORLSTACT
SET ORLSTACT=$ORDER(^OR(100,+ORID,8,"A"),-1)
+3 IF $PIECE(^OR(100,+ORID,8,ORLSTACT,0),U,2)="HD"
SET ORY=1
+4 QUIT
+5 ;
CSCHECK(ORCSVAL,OROI,ORPSTYPE) ; return 1 if OI is a controlled substance, 0 for non-controlled substance
+1 ;ORCSVAL=1:controlled substance, 0:non-controlled substance
+2 ;OROI=OR orderable item
+3 ;ORPSTYPE="O":Outpatient pharmacy order, "I" or "U":Inpatient med order
+4 NEW ORPSOI,ORTPKG,ORDEAFLG,ORDETOX
+5 SET ORCSVAL=0_U_0
SET ORTPKG=$PIECE($GET(^ORD(101.43,+$GET(OROI),0)),U,2)
+6 IF ORPSTYPE="I"
QUIT
+7 if ORTPKG'["PS"
QUIT
+8 SET ORPSOI=+ORTPKG
if ORPSOI'>0
QUIT
+9 IF '$LENGTH($TEXT(OIDEA^PSSUTLA1))
QUIT
+10 SET ORDEAFLG=+$$OIDEA^PSSOPKI(ORPSOI,ORPSTYPE)
+11 IF ORDEAFLG'>0
SET ORCSVAL=0
+12 IF ORDEAFLG>0
SET ORCSVAL=1
+13 SET ORDETOX=0
+14 ;get detox value either from OIDEA^PSSUTLA1 or from different api or method
+15 SET ORDETOX=$$OIDETOX^PSSOPKI(ORPSOI,ORPSTYPE)
+16 SET ORCSVAL=ORCSVAL_U_ORDETOX
+17 QUIT
SIGINFO(ORY,ORDFN,ORPROV,OROID) ;returns the provider/patient info that must be displayed when signing controlled substance orders
+1 NEW ORI
SET ORI=0
+2 ;patient name
+3 SET ORI=ORI+1
SET ORY(ORI)=$PIECE(^DPT(+ORDFN,0),U)
+4 ;date of issuance
+5 SET ORI=ORI+1
SET ORY(ORI)="Date of Issuance: "_$$FMTE^XLFDT($$DT^XLFDT)
+6 ;provider name
+7 SET ORI=ORI+1
SET ORY(ORI)="Provider: "_$$GET1^DIQ(200,ORPROV,.01,"E")
+8 ;provider address (facility address)
+9 NEW ORINST
+10 DO GETS^DIQ(4,DUZ(2),".01;.02;1.01;1.02;1.03;1.04","E","ORINST")
+11 NEW ORADDNUM
SET ORADDNUM=0
+12 IF $LENGTH(ORINST(4,DUZ(2)_",",1.01,"E"))>0
SET ORI=ORI+1
SET ORY(ORI)=ORINST(4,DUZ(2)_",",1.01,"E")
SET ORADDNUM=ORADDNUM+1
+13 IF $LENGTH(ORINST(4,DUZ(2)_",",1.02,"E"))>0
SET ORI=ORI+1
SET ORY(ORI)=ORINST(4,DUZ(2)_",",1.02,"E")
SET ORADDNUM=ORADDNUM+1
+14 IF $LENGTH(ORINST(4,DUZ(2)_",",1.03,"E"))>0
SET ORI=ORI+1
SET ORY(ORI)=ORINST(4,DUZ(2)_",",1.03,"E")
SET ORADDNUM=ORADDNUM+1
+15 IF $LENGTH(ORINST(4,DUZ(2)_",",.02,"E"))>0
SET ORY(ORI)=ORY(ORI)_", "_ORINST(4,DUZ(2)_",",.02,"E")
SET ORADDNUM=ORADDNUM+1
+16 IF $LENGTH(ORINST(4,DUZ(2)_",",1.04,"E"))>0
SET ORY(ORI)=ORY(ORI)_" "_ORINST(4,DUZ(2)_",",1.04,"E")
SET ORADDNUM=ORADDNUM+1
+17 IF ORADDNUM=0
Begin DoDot:1
+18 SET ORI=ORI+1
SET ORY(ORI)="No Address on record"
+19 IF $LENGTH(ORINST(4,DUZ(2)_",",.01,"E"))>0
SET ORI=ORI+1
SET ORY(ORI)="for "_ORINST(4,DUZ(2)_",",.01,"E")
End DoDot:1
+20 ;dea #
+21 SET ORI=ORI+1
SET ORY(ORI)="DEA: "_$$DEA^XUSER(,ORPROV)
+22 ;*506
+23 IF $GET(OROID)
SET OROID=+OROID
IF $PIECE($GET(^OR(100,OROID,11.1)),U)]""
SET ORY(ORI)="DEA: "_$PIECE(^OR(100,OROID,11.1),U)
+24 ;detox #
+25 ; $$DETOX^XUSER(ORPROV) / P607-Remove Detox/X-Waiver
NEW ORDETOX
SET ORDETOX=""
+26 IF $LENGTH(ORDETOX)>0
SET ORI=ORI+1
SET ORY(ORI)="Detox: "_ORDETOX
+27 QUIT
HASHINFO(ORY,ORDFN,ORPROV,OROID) ;basic data for all orders getting signed
+1 NEW ORI
SET ORI=0
+2 ;patient name
+3 SET ORI=ORI+1
SET ORY(ORI)="PatientName:"_$PIECE(^DPT(+ORDFN,0),U)
+4 ;patient address
+5 NEW VAPA,DFN,ORPATADD
+6 SET DFN=ORDFN
+7 DO ADD^VADPT
+8 SET ORPATADD=VAPA(1)_U_VAPA(2)_U_VAPA(3)_U_VAPA(4)_U_$PIECE(VAPA(5),"^")_U_$PIECE(VAPA(5),"^",2)_U_VAPA(6)_U_VAPA(7)
+9 SET ORI=ORI+1
SET ORY(ORI)="PatientAddress:"_ORPATADD
+10 ;date of issuance
+11 SET ORI=ORI+1
SET ORY(ORI)="IssuanceDate:"_$$FMTE^XLFDT($$DT^XLFDT)
+12 SET ORI=ORI+1
SET ORY(ORI)="IssuanceInt:"_$$DT^XLFDT
+13 ;provider name
+14 SET ORI=ORI+1
SET ORY(ORI)="ProviderName:"_$$GET1^DIQ(200,ORPROV,.01,"E")
+15 SET ORI=ORI+1
SET ORY(ORI)="ProviderNumber:"_ORPROV
+16 ;provider address (facility address)
+17 NEW ORINST
+18 DO GETS^DIQ(4,DUZ(2),".01;.02;1.01;1.02;1.03;1.04","E","ORINST")
+19 SET ORI=ORI+1
SET ORY(ORI)="ProviderAddress:"_ORINST(4,DUZ(2)_",",1.01,"E")_U_ORINST(4,DUZ(2)_",",1.02,"E")_U_ORINST(4,DUZ(2)_",",1.03,"E")_U_ORINST(4,DUZ(2)_",",.02,"E")_U_ORINST(4,DUZ(2)_",",1.04,"E")
+20 SET ORI=ORI+1
SET ORY(ORI)="ProviderAdd1:"_ORINST(4,DUZ(2)_",",.01,"E")
+21 ;dea #
+22 SET ORI=ORI+1
SET ORY(ORI)="DeaNumber:"_$$DEA^XUSER(,ORPROV)
+23 ;*499 - DEA# from backdoor pharmacy or from CPRS order entry
+24 SET OROID=+$GET(OROID)
NEW ORSLDEA
SET ORSLDEA=""
+25 IF OROID
IF $PIECE($GET(^OR(100,OROID,11.1)),U)]""
SET ORSLDEA=$PIECE(^OR(100,OROID,11.1),U)
+26 IF ORSLDEA=""
IF $PIECE($GET(RXE),"|",14)]""
SET ORSLDEA=$PIECE($GET(RXE),"|",14)
+27 IF ORSLDEA]""
SET ORI=ORI+1
SET ORY(ORI)="DeaNumber:"_ORSLDEA
+28 IF ORSLDEA=""
SET ORI=ORI+1
SET ORY(ORI)="DeaNumber:"_$$DEA^XUSER(,ORPROV)
+29 ;detox #
+30 ;$$DETOX^XUSER(ORPROV) / P607-Remove Detox/X-Waiver
NEW ORDETOX
SET ORDETOX=""
+31 IF $LENGTH(ORDETOX)>0
SET ORI=ORI+1
SET ORY(ORI)="DetoxNumber:"_ORDETOX
+32 QUIT
ORDHINFO(ORY,ORIFN,HASH,OHINFO) ;
+1 NEW IENS
+2 DO BUILDFDA(ORIFN,.ORDFDA,.ORY,$GET(HASH),.OHINFO)
+3 QUIT
BUILDFDA(ORIFN,ORDFDA,OROUT,HASH,OHD) ;
+1 ;ORIFN is the CPRS order number to use
+2 ;returns 0 if not successful, 1 if successful
+3 NEW ERROR,ORDIALOG,A,PIEN,DFN,S1,DOSE,SCHED,ROUTE,I
+4 NEW CONJ,INSTR,SCHED,DUR,DOSE,VADM
+5 IF $GET(ORIFN)=""
QUIT 0
+6 KILL ^TMP($JOB,"ORDEA")
+7 SET ORDIALOG=$$GET1^DIQ(100,ORIFN_",",2,"I")
IF ORDIALOG=""
QUIT 0
+8 DO GETDLG^ORCD(+ORDIALOG)
DO GETORDER^ORCD("^OR(100,"_ORIFN_",4.5)")
+9 SET INSTR=$$PTR("INSTRUCTIONS")
SET SCHED=$$PTR("SCHEDULE")
SET DUR=$$PTR("DURATION")
SET DOSE=$$PTR("DOSE")
+10 SET CONJ=$$PTR("AND/THEN")
SET ROUTE=$$PTR("ROUTE")
+11 SET IENS="+1,"
+12 FOR I=1:1
if '$DATA(OHD(I))
QUIT
Begin DoDot:1
+13 IF $GET(OHD(I))["IssuanceInt"
SET ORDFDA(101.52,IENS,4)=$PIECE(OHD(I),":",2,99)
QUIT
+14 IF $GET(OHD(I))["ProviderNumber"
SET ORDFDA(101.52,IENS,31)=$PIECE(OHD(I),":",2,99)
QUIT
+15 IF $GET(OHD(I))["ProviderName"
SET ORDFDA(101.52,IENS,12)=$PIECE(OHD(I),":",2,99)
QUIT
+16 IF $GET(OHD(I))["DeaNumber"
SET ORDFDA(101.52,IENS,10)=$PIECE(OHD(I),":",2,99)
QUIT
+17 IF $GET(OHD(I))["DetoxNumber"
SET ORDFDA(101.52,IENS,11)=$PIECE(OHD(I),":",2,99)
QUIT
+18 IF $GET(OHD(I))["ProviderAdd1"
SET ORDFDA(101.52,IENS,13)=$PIECE(OHD(I),":",2,99)
QUIT
+19 IF $GET(OHD(I))["ProviderAddress"
Begin DoDot:2
+20 SET A=$PIECE(OHD(I),":",2,99)
+21 SET ORDFDA(101.52,IENS,14)=$PIECE(A,"^")
SET ORDFDA(101.52,IENS,15)=$PIECE(A,"^",2)
+22 SET ORDFDA(101.52,IENS,16)=$PIECE(A,"^",3)
SET ORDFDA(101.52,IENS,17)=$PIECE(A,"^",4)
+23 SET ORDFDA(101.52,IENS,17.5)=$PIECE(A,"^",5)
End DoDot:2
+24 IF $GET(OHD(I))["PatientAddress"
Begin DoDot:2
+25 SET A=$PIECE(OHD(I),":",2,99)
+26 SET ORDFDA(101.52,IENS,21)=$PIECE(A,"^")
SET ORDFDA(101.52,IENS,22)=$PIECE(A,"^",2)
SET ORDFDA(101.52,IENS,24)=$PIECE(A,"^",3)
+27 SET ORDFDA(101.52,IENS,25)=$PIECE(A,"^",4)
SET ORDFDA(101.52,IENS,26)=$PIECE(A,"^",6)
SET ORDFDA(101.52,IENS,27)=$PIECE(A,"^",7)
End DoDot:2
End DoDot:1
+28 SET ORDFDA(101.52,IENS,.01)=ORIFN
+29 SET A=$PIECE($GET(ORDIALOG("B","DISPENSE DRUG")),"^",2)
SET PIEN=$GET(ORDIALOG(A,1))
Begin DoDot:1
+30 IF PIEN=""
SET OROUT(1)="DrugName:"
QUIT
+31 DO DATA^PSS50(PIEN,"","","","","ORDEA")
+32 SET ORDFDA(101.52,IENS,6)=^TMP($JOB,"ORDEA",PIEN,.01)
SET ORDFDA(101.52,IENS,29)=PIEN
SET ORDFDA(101.52,IENS,30)=^TMP($JOB,"ORDEA",PIEN,3)
+33 SET OROUT(1)="DrugName:"_^TMP($JOB,"ORDEA",PIEN,.01)
End DoDot:1
+34 SET INSTR=$ORDER(^ORD(101.41,"AB","OR GTX INSTRUCTIONS",0))
+35 SET A=$PIECE($GET(ORDIALOG("B","QUANTITY")),"^",2)
SET ORDFDA(101.52,IENS,8)=$GET(ORDIALOG(A,1))
+36 SET OROUT(2)="Quantity:"_$GET(ORDIALOG(A,1))
+37 SET A=$PIECE($GET(ORDIALOG("B","REFILLS")),"^",2)
SET ORDFDA(101.52,IENS,28)=$GET(ORDIALOG(A,1))
+38 SET S1=0
FOR I=1:1
if '$DATA(ORDIALOG(INSTR,I))
QUIT
Begin DoDot:1
+39 SET A=$PIECE($GET(ORDIALOG(DOSE,I)),"&",1,6)_"|"_$GET(ORDIALOG(SCHED,I))_"|"_$$DUR($GET(ORDIALOG(DUR,I)))_"|"_$$CONJ($GET(ORDIALOG(CONJ,I)))_"|"_$GET(ORDIALOG(ROUTE,I))
+40 SET ORDFDA(101.529,"+"_(I+1)_","_IENS,.01)=A
+41 IF '$DATA(OROUT(3))
SET OROUT(3)="Directions:"_A
+42 IF '$TEST
SET OROUT(3)=OROUT(3)_A
End DoDot:1
+43 SET A=+$$GET1^DIQ(100,ORIFN_",",6,"I")
SET A=$$GET1^DIQ(44,A,3,"I")
+44 SET DFN=+$$GET1^DIQ(100,ORIFN_",",.02,"I")
SET A=$$GETICN^MPIF001(DFN)
SET ORDFDA(101.52,IENS,20)=$SELECT(A["^":"",1:A)
+45 DO DEM^VADPT
SET ORDFDA(101.52,IENS,18)=VADM(1)
SET ORDFDA(101.52,IENS,19)=DFN
+46 SET ORDFDA(101.52,IENS,2)=$GET(HASH)
+47 QUIT
BUILD(ORIFN) ;Build ARCHIVE entry for CPRS order number
+1 NEW ORDFDA,OROUT,ERROR
+2 DO BUILDFDA(ORIFN,.ORDFDA,.OROUT)
+3 DO UPDATE^DIE("","ORDFDA","ORIEN","ERROR")
+4 QUIT 1
SUBSCRIB(ORIFN,RXN) ;API for Pharmacy to subscribe to an archive entry
+1 ;ORIFN is the CPRS order number of the archive Pharmacy wants to use
+2 ;RXN is the Pharmacy prescription number that is subscribing to the archive
+3 ;returns a 0 if not successful
+4 ;returns a 1 if successful
+5 NEW A,IEN,ORDFDA,ERROR
+6 IF $GET(ORIFN)=""!($GET(RXN)="")
QUIT 0
+7 SET IEN=$$FIND1^DIC(101.52,"","MXQ",ORIFN,"","","ERR")
+8 IF 'IEN
QUIT 0
+9 SET A=$$GET1^DIQ(101.52,IEN_",",1,"I")
IF A]""
IF A'=RXN
QUIT 0
+10 SET ORDFDA(101.52,IEN_",",1)=RXN
+11 DO FILE^DIE("","ORDFDA","ERROR")
+12 IF $DATA(ERROR)
QUIT 0
+13 QUIT 1
ARCHIVE(ORIFN) ;retrieve archive for specified order number
+1 ;ORIFN is the CPRS order number whose archive is requested
+2 IF $GET(ORIFN)=""
QUIT
+3 KILL ^TMP($JOB,"ORDEA",ORIFN)
NEW IEN,ERROR,ORDEA,A,I,S1
+4 SET IEN=$$FIND1^DIC(101.52,"","MXQ",ORIFN,"","","ERR")
+5 IF 'IEN
QUIT
+6 SET IEN=IEN_","
+7 DO GETS^DIQ(101.52,IEN,"**","IE","ORDEA","ERROR")
IF $DATA(ERROR)
QUIT
+8 SET A(1)=""
FOR I=1,4,6,29,30,8,28
SET A(1)=A(1)_$GET(ORDEA(101.52,IEN,I,"I"))_"^"
+9 SET A(1)=$PIECE(A(1),"^",1,7)
+10 SET A(2)=""
FOR I=10,11,12,31
SET A(2)=A(2)_$GET(ORDEA(101.52,IEN,I,"I"))_"^"
+11 SET A(2)=$PIECE(A(2),"^",1,4)
+12 SET A(3)=""
FOR I=13,14,15,16,17,17.5
SET A(3)=A(3)_$GET(ORDEA(101.52,IEN,I,"I"))_"^"
+13 SET A(3)=$PIECE(A(3),"^",1,6)
+14 SET A(4)=""
FOR I=18,19,20
SET A(4)=A(4)_$GET(ORDEA(101.52,IEN,I,"I"))_"^"
+15 SET A(4)=$PIECE(A(4),"^",1,3)
+16 SET A(5)=""
FOR I=21,22,24,25,26,27
SET A(5)=A(5)_$GET(ORDEA(101.52,IEN,I,"I"))_"^"
+17 SET A(5)=$PIECE(A(5),"^",1,6)
+18 FOR I=1:1:5
SET ^TMP($JOB,"ORDEA",ORIFN,I)=A(I)
+19 SET S1=0
FOR
SET S1=$ORDER(ORDEA(101.529,S1))
if 'S1
QUIT
SET ^TMP($JOB,"ORDEA",ORIFN,6,$PIECE(S1,","))=ORDEA(101.529,S1,.01,"I")
+20 QUIT
HASHRTN(ORIFN) ;returns hash of a specified archive entry
+1 ;ORIFN is the CPRS order number for the archive
+2 NEW IEN,ORHASH,ERR,ERROR
+3 SET IEN=$$FIND1^DIC(101.52,"","MXQ",ORIFN,"","","ERR")
+4 IF 'IEN
QUIT 0
+5 SET IEN=IEN_","
+6 SET ORHASH=$$GET1^DIQ(101.52,IEN,2,"I","","ERROR")
IF $DATA(ERROR)
QUIT 0
+7 QUIT ORHASH
BACKDOOR(ORIFN,ORPROV,ORD) ;create archive for new backdoor order
+1 ;called from ORMPS
+2 NEW DFN,OHD,OUT,ORDFDA,PIEN,A,ORSCHED,S1
+3 KILL ^TMP($JOB,"ORDEAB")
+4 if $GET(ORIFN)=""
QUIT
IF '$DATA(^OR(100,ORIFN,0))
QUIT
+5 IF $PIECE($GET(^ORD(101.41,+ORD,0)),"^")'="PSO OERR"
QUIT
+6 SET S1=0
FOR
SET S1=$ORDER(ORD(S1))
if 'S1
QUIT
IF $PIECE(ORD(S1),"^",2)["DRUG"
SET PIEN=$GET(ORD(S1,1))
IF PIEN]""
QUIT
+7 IF $GET(PIEN)=""
QUIT
+8 DO DATA^PSS50(PIEN,"","","","","ORDEAB")
SET ORSCHED=$GET(^TMP($JOB,"ORDEAB",PIEN,3))
+9 IF ORSCHED'?1N.E
QUIT
+10 IF ",2,3,4,5,"'[$EXTRACT(ORSCHED)
QUIT
+11 SET DFN=+$PIECE($GET(^OR(100,ORIFN,0)),"^",2)
+12 DO HASHINFO(.OHD,DFN,ORPROV)
+13 DO BUILDFDA(ORIFN,.ORDFDA,.OUT,"",.OHD)
+14 SET ORDFDA(101.52,IENS,1)=$GET(^OR(100,ORIFN,4))
+15 DO UPDATE^DIE("","ORDFDA","","ERROR")
+16 QUIT
PINLKCHK(ORY) ;check if the current user has an active PIN lock
+1 ;ORY=1 if there is an active lock and ORY=0 if no active lock
+2 SET ORY=0
+3 if '$DATA(^XTMP("OR DEA PIN LOCK",DUZ))
QUIT
+4 NEW ORDIFF
+5 SET ORDIFF=$$FMDIFF^XLFDT($$NOW^XLFDT,$GET(^XTMP("OR DEA PIN LOCK",DUZ)),2)
+6 ;CHECK IF LOCK IS LESS THAN 15 MINUTES OLD
+7 IF ORDIFF<900
SET ORY=1
+8 QUIT
PINLKSET(ORY) ;set a PIN lock on the current user
+1 SET ^XTMP("OR DEA PIN LOCK",0)=$$FMADD^XLFDT($$NOW^XLFDT,2)_U_$$NOW^XLFDT
+2 SET ^XTMP("OR DEA PIN LOCK",DUZ)=$$NOW^XLFDT
+3 SET ORY=^XTMP("OR DEA PIN LOCK",DUZ)
+4 QUIT
LNKMSG(ORY) ;message to display after successful PIV link for admin contact person
+1 NEW I,ORTY
+2 DO GETWP^XPAR(.ORTY,"DIV^SYS^PKG","OR DEA PIV LINK MSG")
+3 SET I=0
FOR
SET I=$ORDER(ORTY(I))
if 'I
QUIT
SET ORY(I)=ORTY(I,0)
+4 QUIT
PTR(NAME) ; -- Returns ptr value of prompt in Dialog file
+1 QUIT +$ORDER(^ORD(101.41,"AB",$EXTRACT("OR GTX "_NAME,1,63),0))
DUR(DUR) ;
+1 QUIT $SELECT(DUR="":"",DUR=0:"",1:$EXTRACT($PIECE(DUR," ",2))_+DUR)
CONJ(CNJ) ;
+1 QUIT $SELECT(CNJ="":"",CNJ'="T":CNJ,1:"S")
+2 ;
AUINTENT(ORY,ORIFN,ORSTATE) ; Audit 'intention to sign' CS ePCS Order
+1 ;
+2 ; ZEXCEPT: DILOCKTM
+3 NEW ORFDA
+4 ;
+5 SET ORY=0
+6 IF '$GET(ORIFN)
QUIT
+7 SET ORIFN=+ORIFN
+8 IF '$DATA(^OR(100,ORIFN,0))
QUIT
+9 IF $GET(ORSTATE)'?1(1"1",1"0")
QUIT
+10 SET ORY=1
+11 ;
+12 SET ORFDA(101.51,"?+1,",.01)=ORIFN
+13 SET ORFDA(101.511,"+2,?+1,",.01)=$$NOW^XLFDT
+14 SET ORFDA(101.511,"+2,?+1,",.02)=DUZ
+15 SET ORFDA(101.511,"+2,?+1,",.03)=ORSTATE
+16 LOCK +^ORD(101.51,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
+17 DO UPDATE^DIE("","ORFDA")
+18 LOCK -^ORD(101.51,0)
+19 DO CLEAN^DILF
+20 ;
+21 QUIT
+22 ;
AUDORDXX(ORIFN) ;Audit change to unsigned CS ePCS Order
+1 ;
+2 ; ZEXCEPT: DILOCKTM
+3 NEW DFN,ORARR,ORAUDFDA,ORAUDIT,ORDFDA,ORFIELD,ORFILE,ORHASHINFO,ORLN,ORPROV
+4 ;
+5 IF '$GET(ORIFN)
QUIT
+6 SET ORIFN=+ORIFN
+7 ;
+8 SET ORAUDFDA(101.51,"?+1,",.01)=ORIFN
+9 SET ORAUDFDA(101.511,"+2,?+1,",.01)=$$NOW^XLFDT
+10 SET ORAUDFDA(101.511,"+2,?+1,",.02)=DUZ
+11 ;
+12 ; Set up ORAUDIT with fields that need to be audited.
+13 ; We want to audit the same fields that are being archived to 101.52.
+14 SET DFN=+$PIECE($GET(^OR(100,ORIFN,0)),U,2)
+15 SET ORPROV=$PIECE($GET(^OR(100,ORIFN,8,1,0)),U,3)
+16 IF 'ORPROV
SET ORPROV=DUZ
+17 DO HASHINFO(.ORHASHINFO,DFN,ORPROV)
+18 DO ORDHINFO(,ORIFN,,.ORHASHINFO)
+19 ; Convert ORDFDA (generated by ORDHINFO) into word-processing array (ORAUDIT) that we can log to 101.51
+20 SET ORLN=0
+21 SET ORARR="ORDFDA"
+22 FOR
SET ORARR=$QUERY(@ORARR)
if ORARR=""
QUIT
if $QSUBSCRIPT(ORARR,0)'="ORDFDA"
QUIT
Begin DoDot:1
+23 SET ORFILE=$QSUBSCRIPT(ORARR,1)
+24 SET ORFIELD=$QSUBSCRIPT(ORARR,3)
+25 IF 'ORFILE!('ORFIELD)
QUIT
+26 IF ORFILE="101.52"
IF ((ORFIELD=".01")!(ORFIELD=2))
QUIT
+27 SET ORLN=ORLN+1
+28 SET ORAUDIT(ORLN)=$$GET1^DID(ORFILE,ORFIELD,,"LABEL")_": "_$GET(@ORARR)
End DoDot:1
+29 IF $DATA(ORAUDIT)
SET ORAUDFDA(101.511,"+2,?+1,",1)="ORAUDIT"
+30 ;
+31 LOCK +^ORD(101.51,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
+32 DO UPDATE^DIE("","ORAUDFDA")
+33 LOCK -^ORD(101.51,0)
+34 DO CLEAN^DILF
+35 ;
+36 QUIT
+37 ;
