PSBML ;BIRMINGHAM/EFC-BCMA MED LOG FUNCTIONS ;03/06/16 3:06pm
;;3.0;BAR CODE MED ADMIN;**6,3,4,9,11,13,25,45,33,52,70,72,79,94,83,98**;Mar 2004;Build 2
;Per VA Directive 6402, this routine should not be modified.
; Reference/IA
; ^DPT/10035
; DIC(42/10039
; DIC(42/2440
; File 200/10060
; EN^PSJBCMA3/3320
; $$SITE^VASITE/10112
; ^XUSEC(/10076
;
;*70 - store clinic name to admin location if exists.
; - add witness duz, dt/tm for high risk/alert drug, Order level
; HR code, and a witnessed y/n flag to MEDLOG file.
;*83 - store MRR code to DD multiple .06 field, to update AMRR xref
; - store Scheduled Removal time in a new field in 53.79
; - change offset of incoming array from 10th to 11th piece.
;
RPC(RESULTS,PSBHDR,PSBREC) ;BCMA MedLog Filing
K PSBEDTFL
S PSBEDTFL=0
N PSBORD,PSBTRAN,PSBFDA,PSBMES ;Add PSBMES variable for PSB*3*52
N PSBCLIN,PSBWITN,PSBWITCM,PSBWITHR,PSBWITFL,LOC ;*70
N PSBACTN ;used for trigger xref code *83
K PSBIEN,PSBHL7,%,PSBAUDIT,PSBINST
S PSBIEN=$P(PSBHDR,U,1)
S PSBTRAN=$P(PSBHDR,U,2),PSBHL7=PSBTRAN
S PSBINST=$P($G(PSBHDR),U,3)
;*70 witness fields
S PSBWITN=+$P(PSBHDR,U,4) ;init witness duz var
S PSBWITCM=$P(PSBHDR,U,5) ;init witness comment
S PSBWITHR=+$P(PSBHDR,U,6) ;init witness HR order level
S PSBWITFL=$S(PSBWITN:1,1:0) ;init witnessed?
I PSBWITN="",PSBWITHR=3 D Q
.S RESULTS(0)=1
.S RESULTS(1)="-1^A Witness is required, however Witness information was null."
;PSB*3*45 We should be recording the first entry in the audit log.
;S PSBAUDIT=$S(PSBIEN="+1":0,1:1)
S PSBAUDIT=1
D NOW^%DTC S PSBNOW=%
I $D(^XUSEC("PSB STUDENT",DUZ)),PSBINST="" S RESULTS(0)=1,RESULTS(1)="-1^Instructor not present" Q
I $D(^XUSEC("PSB STUDENT",DUZ)),'$D(^XUSEC("PSB INSTRUCTOR",PSBINST)) S RESULTS(0)=1,RESULTS(1)="-1^Instructor doesn't have authority" Q
S PSBINST(0)=$$GET1^DIQ(200,PSBINST_",",.01)
I PSBTRAN="ADD COMMENT" D COMMENT^PSBML1 Q
I PSBTRAN="PRN EFFECTIVENESS" D PRN^PSBML1 Q
;
;update medlog rec
UPD I PSBTRAN="UPDATE STATUS" D Q
.K PSBTAB,PSBUID
.S PSBACTN=PSBREC(0) ;var for trigger code for Variance calcs *83
.I '$D(^PSB(53.79,PSBIEN)) D Q
..S RESULTS(0)=1
..S RESULTS(1)="-1^Administration is at an UNKNOWN STATUS"
.D UPDATED^PSBML2
;
;edit Medlog rec
EDITML I PSBTRAN="EDIT" D EDIT^PSBML2 Q
;
;SAGG
N PSBWARD S PSBWARD=$G(^DPT(+$G(PSBREC(0)),.1),"UNKNOWN"),^PSB("SAGG",PSBWARD,DT)=$G(^PSB("SAGG",PSBWARD,DT))+1
;*70 save clinic name if exists before manipulating PSBREC(1) param
S PSBCLIN=$P(PSBREC(1),U,2) I PSBCLIN="" S PSBCLIN=$S($G(PSBCLIEN):$P($G(^SC(+PSBCLIEN,0)),"^"),($G(PSBCLORD)]""):PSBCLORD,1:"")
S PSBREC(1)=$P(PSBREC(1),U)
;
;pre-existing psbrec(1) manipulation logic to *70
I PSBREC(1)?1U1";"1.6N S PSBREC(1)=$P(PSBREC(1),";",1)_$E(PSBREC(1))
D PSJ1^PSBVT(PSBREC(0),$P(PSBREC(1),";",2)_$P(PSBREC(1),";",1))
S PSBTAB=$P(PSBREC(9),U,1),PSBUID=$P(PSBREC(9),U,2)
MEDP D:PSBTRAN="MEDPASS"
.K PSBDIV,PSBON,PSBXDT,PSBYZ
.S PSBACTN=PSBREC(3) ;var for trigger code for Variance calcs *83
.I ((PSBDOSEF["PATCH")!(PSBMRRFL)),(PSBREC(3)="G") D Q:+$G(RESULTS(1))<0 ;add MRR flag to test *83
..S PSBXDT="" F S PSBXDT=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXDT)) Q:PSBXDT="" D Q:+$G(RESULTS(1))<0
...S PSBYZ="" F S PSBYZ=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXDT,PSBYZ)) Q:'PSBYZ I ("G"[$$GET1^DIQ(53.79,PSBYZ,.09,"I")) D Q
....S:($$GET1^DIQ(53.79,PSBYZ,.09,"I")="G") RESULTS(0)=1,RESULTS(1)="-1^Previous administration has not been removed. Administration canceled.^" ;make generic verbiage *83
....S:($$GET1^DIQ(53.79,PSBYZ,.09,"I")="")&(($$GET1^DIQ(53.79,PSBYZ,.07,"I")'=DUZ)&('$D(^XUSEC("PSB MANAGER",DUZ)))) RESULTS(0)=1,RESULTS(1)="-1^Patch status ""*UNKNOWN*"". Administration canceled."
.I PSBREC(7)="BCMA/CPRS Interface Entry." S PSBNOW=PSBREC(5) ;MOB
.F X=0:1:9 S PSBREC(X)=$G(PSBREC(X))
.I PSBREC(1)?1U1";".N S PSBREC(1)=$P(PSBREC(1),";",2)_$P(PSBREC(1),";",1)
.I PSBREC(1)["V",+PSBREC(5)>0,+$P(PSBREC(5),".",2)=0,PSBIVT'["P" D NOW^%DTC S PSBREC(5)=$P(PSBREC(5),".",1)_"."_$P(%,".",2)
.I $P(PSBREC(9),U,1)="IVTAB",$P(PSBREC(9),U,2)="" S PSBUID=$$GETWSID^PSBVDLU2(PSBREC(0),PSBREC(1))
.I $P(PSBREC(9),U,1)="PBTAB",$P(PSBREC(9),U,2)="",PSBREC(1)'["U",PSBREC(3)'="M",PSBREC(3)'="R",PSBREC(3)'="H" S PSBUID=$$GETWSID^PSBVDLU2(PSBREC(0),PSBREC(1))
.;OnCal
.D:PSBREC(2)="OC"
..S X=$O(^PSB(53.79,"AORD",PSBREC(0),PSBREC(1),"")) Q:X=""
..S Y=$O(^PSB(53.79,"AORD",PSBREC(0),PSBREC(1),X,0))
..I $P(^PSB(53.79,Y,0),U,9)="G"&('$$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL")) D ERR(1,"On-Call already given")
.;1x
.D:PSBREC(2)="O"
..S X=$O(^PSB(53.79,"AORD",PSBREC(0),PSBREC(1),"")) Q:X=""
..S Y=$O(^PSB(53.79,"AORD",PSBREC(0),PSBREC(1),X,0))
..I $P(^PSB(53.79,Y,0),U,9)="G" D ERR(1,"One Time already Given")
.;PRN
.I PSBREC(2)="P",PSBREC(3)'="M",$P(PSBREC(9),U,1)'="IVTAB" D
..I PSBREC(6)="" D ERR(1,"PRN Medications MUST Have a PRN Reason")
..I PSBREC(5)]"" D ERR(1,"PRN Orders don't have scheduled times")
..I PSBREC(3)'="G" D ERR(1,"PRN Orders cannot be marked NOT Given")
.;Cnt
.I PSBREC(2)="C",PSBTAB'="IVTAB" D
..D:PSBREC(5)="" ERR(1,"Continuous Order needs admin time")
..D:PSBREC(6)]"" ERR(1,"No PRN Reason allowed on Continuous Orders")
.I PSBREC(2)="C",$D(^PSB(53.79,"AORD",PSBREC(0),PSBREC(1),+PSBREC(5))),PSBIEN="+1" D K PSBADMBY,PSBADMAT Q:PSBSIEN="" Q:$P(^PSB(53.79,PSBSIEN,0),U,9)'="N"
..S PSBSIEN=$O(^PSB(53.79,"AORD",PSBREC(0),PSBREC(1),PSBREC(5),""))
..I PSBSIEN]"" I '(($P(^PSB(53.79,PSBSIEN,0),U,7)=DUZ)!($D(^XUSEC("PSB MANAGER",DUZ)))) S PSBSIEN=""
..I PSBSIEN']"" S RESULTS(0)=2,RESULTS(1)="-2^Error Filing Transaction MEDPASS",RESULTS(2)="The PSB MANAGER key is required to modify this scheduled admin" Q
..D:$P(^PSB(53.79,PSBSIEN,0),U,9)'="N"
...K PSBINCX I $P(^PSB(53.79,PSBSIEN,0),U,9)="" S PSBINCX=PSBSIEN L +^PSB(53.79,PSBINCX):1 Q:'$T L -^PSB(53.79,PSBINCX)
...S Y=$P(^PSB(53.79,PSBSIEN,0),U,6) D DD^%DT S PSBADMAT=Y
...S PSBADMBY=$$GET1^DIQ(200,$P(^PSB(53.79,PSBSIEN,0),U,7),.01,)
...S RESULTS(0)=3,RESULTS(1)="-2^Error Filing Transaction MEDPASS"
...S RESULTS(2)="Continuous Administration Date/Time already on file."
...S RESULTS(3)="Administered by "_PSBADMBY_" at "_PSBADMAT_"."
...I $D(XWB) S RESULTS(0)=RESULTS(0)+2,RESULTS(4)=" ",RESULTS(5)=" VDL will now be updated."
.;Non Given
.I PSBREC(3)'="G",PSBREC(3)'="M",PSBUID'["V",PSBUID'["W" D
..I PSBREC(7)="",PSBTAB'="IVTAB" D ERR(1,"Comment needed if Not Marked Given")
..I PSBREC(7)="",PSBTAB="IVTAB" D ERR(1,"Comment needed if Not Marked Completed")
.S:PSBREC(3)="H" PSBREC(7)="Held: "_PSBREC(7) ;.3
.S:PSBREC(3)="R" PSBREC(7)="Refused: "_PSBREC(7) ;.3
.S:PSBREC(3)="S" PSBREC(7)="Stopped: "_PSBREC(7) ;.3
.;Valid?
.I $G(PSBSIEN)'="" I $D(^PSB(53.79,PSBSIEN,0)) I $P(^PSB(53.79,PSBSIEN,0),U,9)="N" S PSBIEN=+PSBSIEN_",",$P(PSBHDR,U)=PSBIEN,PSBTRAN="UPDATE STATUS",PSBAUDIT=1 ;do UPDATE
.D:PSBIEN="+1" ;New fields only?
..D VAL(53.79,PSBIEN,.01,"`"_PSBREC(0)) ;Patn
..S LOC=$G(^DPT(PSBREC(0),.1))_" "_$G(^(.101)) ;Ward Room/Bed LOC
..S:PSBCLIN]"" LOC=PSBCLIN ;If clinic order use clin name *70
..D VAL(53.79,PSBIEN,.02,LOC) ;Patn Location LOC
..D:$G(^DPT(PSBREC(0),.1))'=""
...S Y=$O(^DIC(42,"B",$G(^DPT(PSBREC(0),.1)),"")),Y=$$GET1^DIQ(42,Y,.015,"I"),PSBDIV=$$SITE^VASITE(DT,Y)
...D VAL(53.79,PSBIEN,.03,"`"_$P(PSBDIV,U,1)) ;Div
..D VAL(53.79,PSBIEN,.04,PSBNOW) ;Entered dt/tm
..D VAL(53.79,PSBIEN,.05,"`"_DUZ) ;Entered by duz
..D VAL(53.79,PSBIEN,.06,PSBNOW) ;Admin dt/tm
..D VAL(53.79,PSBIEN,.07,"`"_DUZ) ;Admin By duz
..D VAL(53.79,PSBIEN,.08,"`"_PSBREC(4)) ;Orderable Item
..D VAL(53.79,PSBIEN,.11,PSBREC(1)) ;Ord file 55 IEN
..D VAL(53.79,PSBIEN,.12,PSBREC(2)) ;Ord Schd Type
..D VAL(53.79,PSBIEN,.13,PSBREC(5)) ;Schd Admin dt/tm
..I $P($G(PSBREC(10)),".",2)]"" D
...D VAL(53.79,PSBIEN,.17,PSBREC(10)) ;Schd Remove dt/tm
..D:PSBTAB'="UDTAB" VAL(53.79,PSBIEN,.26,PSBUID) ;IV Bag ID
..D:PSBTAB="IVTAB" VAL(53.79,PSBIEN,.13,"") ;Schd Admdt/tm null
..D:PSBREC(1)?.N1"U" VAL(53.79,PSBIEN,.15,PSBDOSE) ;UD Dosage
..D:PSBREC(1)?.N1"V" VAL(53.79,PSBIEN,.35,PSBIFR) ;IV Infuse Rate
..I PSBWITHR>1,(PSBREC(3)="G")!(PSBREC(3)="I") D ;Witness logic and Give? *70
...D:PSBWITN VAL(53.79,PSBIEN,.28,PSBNOW) ;Witness dt/time
...D:PSBWITN VAL(53.79,PSBIEN,.29,"`"_PSBWITN) ;Witness duz
...D:PSBWITCM]"" VAL(53.79,PSBIEN,.31,PSBWITCM) ;Witness comment
...D VAL(53.79,PSBIEN,.32,PSBWITHR) ;Witness HR ord code
...D VAL(53.79,PSBIEN,.33,PSBWITFL) ;Witnessed? flag
.;
.;Overwrite fields below, rec already exists
.I PSBREC(3)="G"!(PSBREC(3))="C" D ;Gvn/Completed?
..D VAL(53.79,PSBIEN,.06,PSBNOW) ;Admin dt/tm
..D VAL(53.79,PSBIEN,.07,"`"_DUZ) ;Admin By duz
.; set Derm/Inj site fields *83
.I PSBREC(8)]"" D
..N SITETXT,SITECD
..S SITETXT=$P(PSBREC(8),"|",1),SITECD=$P(PSBREC(8),"|",2)
..I SITECD="D" D ;If dermal, else assume inj site
...D VAL(53.79,PSBIEN,.18,SITETXT) ;Dermal site
..E D
...D VAL(53.79,PSBIEN,.16,SITETXT) ;Inject site
.;
.D:'$G(PSBMMEN) VAL(53.79,PSBIEN,.09,PSBREC(3)) ;AStats
.I PSBREC(6)]"" D ;PRN reason?
..D VAL(53.79,PSBIEN,.21,$P(PSBREC(6),U)) ;reason dt/tm
..D VAL(53.79,PSBIEN,.27,$P(PSBREC(6),U,2)) ;PRN reason
.D:PSBREC(7)]""
..D VAL(53.793,"+2,"_PSBIEN,.01,PSBREC(7)) ;Comment
..D VAL(53.793,"+2,"_PSBIEN,.02,"`"_DUZ) ;comnt person duz
..D VAL(53.793,"+2,"_PSBIEN,.03,PSBNOW) ;comnt dt/time
.;
.;DD/SOL/ADD
.I PSBREC(3)="G"!(PSBREC(3)="I")!(PSBREC(3)="H")!(PSBREC(3)="R")!(PSBREC(3)="M") D ;given/action stat codes?
..I PSBTRAN="UPDATE STATUS" K ^PSB(53.79,+PSBIEN,.5),^PSB(53.79,+PSBIEN,.6),^PSB(53.79,+PSBIEN,.7)
..;move DD segments to element 11..n No longer 10th *83
..K PSBCNT,PSBIENS
..F PSBCNT=11:1 Q:'$D(PSBREC(PSBCNT)) D
...S Y=$P(PSBREC(PSBCNT),U)
...S PSBDD=$S(Y="DD":53.795,Y="ADD":53.796,Y="SOL":53.797,1:0)
...Q:'PSBDD
...S PSBIENS="+"_PSBCNT_","_PSBIEN
...D VAL(PSBDD,PSBIENS,.01,"`"_$P(PSBREC(PSBCNT),U,2))
...D VAL(PSBDD,PSBIENS,.02,$P(PSBREC(PSBCNT),U,3))
...D:PSBDD=53.795 VAL(PSBDD,PSBIENS,.02,$P(PSBREC(PSBCNT),U,3))
...D:PSBDD=53.796!(PSBDD=53.797) VAL(PSBDD,PSBIENS,.02,$P(PSBREC(PSBCNT),U,4)) ;Store units in Units ordered field, PSB*3*72
...D:PSBREC(3)="G"!(PSBREC(3)="I") VAL(PSBDD,PSBIENS,.03,$P(PSBREC(PSBCNT),U,4)) ;only store units given when infusing or given, PSB*3*72
...D:(PSBTAB="UDTAB")!(PSBTAB="PBTAB") VAL(PSBDD,PSBIENS,.04,$E($P(PSBREC(PSBCNT),U,5),1,40))
...D VAL(PSBDD,PSBIENS,.05,$P(PSBREC(PSBCNT),U,7)) ;HR ind *70
...;.06 field only valid for Unit dose DD type, not for IV's *83
...D:PSBDD=53.795 VAL(PSBDD,PSBIENS,.06,$P(PSBREC(PSBCNT),U,8)) ;MRR
.;Modify Filing Transaction Medpass error message too inclde details - PSB*3*52
.I $O(RESULTS("")) D Q
..N PSBERR
..I $D(PSBMES) D
...S RESULTS(1)="-2^***Your documentation is NOT being recorded in the patient record.***",RESULTS(2)=""
...S RESULTS(3)="Please write down the information (below) AND contact your BCMA Coordinator or IT Support for assistance:",RESULTS(4)=""
...S RESULTS(5)="Error(s) Filing Transaction MEDPASS"
..S PSBERR=0 F S PSBERR=$O(PSBMES(PSBERR)) Q:PSBERR="" D
...S RESULTS($O(RESULTS(""),-1)+1)=PSBMES(PSBERR),RESULTS(0)=$O(RESULTS(""),-1)
.;
.D FILEIT
.;
.;PSB*3*33
.D:((PSBREC(2)="O")!($$ONE^PSJBCMA(PSBREC(0),PSBREC(1))="O"))&(PSBREC(3)="G") EXPIRE^PSBML1 ;1x exp?
.;D:(PSBREC(2)="O")&(PSBREC(3)="G") EXPIRE^PSBML1 ;1x exp? ;Remove second call, which will always be made if above call is true, PSB*3*98
.I $P(RESULTS(0),U,1)=1,PSBTAB'="UDTAB",PSBUID]"",PSBUID'["WS" S PSBON=+PSBREC(1) D EN^PSJBCMA3(PSBREC(0),PSBON,PSBUID,PSBREC(3),PSBNOW)
Q
BCBU ;HL7,NatContng
Q:+$G(RESULTS(0))'>0
N PSBIEN1 S PSBIEN1=$S($P(PSBIEN,",",2)'="":+$P(PSBIEN,",",2),$G(PSBIEN)="+1":PSBIEN(1),1:+$G(PSBIEN))
I $G(PSBIEN1)="" S RESULTS(0)=1,RESULTS(1)="-1^Contingency NOT processed" Q
I $G(PSBIEN)="+1" S PSBHL7="MEDPASS"
E S:$G(PSBHL7)="" PSBHL7="UPDATE STATUS"
D:('$D(Y(0))!($G(Y(0))="SAVE")!($G(Y(0))="YES")) EN^PSBSVHL7(+PSBIEN1,PSBHL7),MEDL^ALPBCBU(+PSBIEN1) K PSBHL7
;<<HDR-VDEF(frm *3)
Q
VAL(PSBDD,PSBIEN,PSBFLD,PSBVAL) ;
K ^TMP("DIERR",$J),PSBRET
D VAL^DIE(PSBDD,PSBIEN,PSBFLD,"F",PSBVAL,.PSBRET,"PSBFDA")
I PSBRET="^" F X=0:0 S X=$O(^TMP("DIERR",$J,X)) Q:'X D ERR(2,^TMP("DIERR",$J,X)_": "_$G(^(X,"TEXT",1),"**"))
K ^TMP("DIERR",$J),PSBRET
Q
FILEIT ;Updt
K Z,X,PSB1,PSB2
N PSBMSG,PSBAUD
S (PSB1,PSB2)=""
D APATCH^PSBML3
D AMRR^PSBML3 ;*83
D CLEAN^DILF
D RESETADM^PSBUTL
D UPDATE^DIE("","PSBFDA","PSBIEN","PSBMSG")
I '$G(PSBMMEN) S X=+PSBIEN I $F("HR",$P(^PSB(53.79,X,0),U,9))>1 F Y=.5,.6,.7 S Z=0 F S Z=$O(^PSB(53.79,+X,Y,Z)) Q:+Z=0 S $P(^PSB(53.79,+X,Y,Z,0),U,3)=0
I $D(PSBMSG("DIERR")) S RESULTS(0)=1,RESULTS(1)="-1^"_PSBMSG("DIERR",1)_": "_PSBMSG("DIERR",1,"TEXT",1) Q
I $G(PSB1)]"" X PSB1 I $G(PSB2)]"" X PSB2
I $G(PSB1A)]"" X PSB1A I $G(PSB2A)]"" X PSB2A ;*83
I $D(PSBHDR) D:"NHMR"[$P(^PSB(53.79,$S($P(PSBHDR,"^",1)="+1":PSBIEN(1),1:+PSBIEN),0),U,9)
.N PSBINDX S PSBINDX=$S($P(PSBHDR,"^",1)="+1":PSBIEN(1),1:+PSBIEN)
.K ^PSB(53.79,"APATCH",$P(^PSB(53.79,PSBINDX,0),U),$P(^PSB(53.79,PSBINDX,0),U,6),PSBINDX)
S RESULTS(0)=1,RESULTS(1)="1^Data Successfully Filed^"_$S($G(PSBIEN(1))'="":$G(PSBIEN(1)),1:+$G(PSBIEN))
D BCBU ;NatContng
D ;
. N X,DIC
. S X="PSB EVSEND VPR",DIC=101 D EN^XQOR ;should handle all BCMA Med Log events for VPR
I $G(PSBINST,0) S PSBAUD=$S($P(PSBHDR,"^",1)="+1":PSBIEN(1),1:$P(PSBHDR,"^",1)) D AUDIT^PSBMLU(PSBAUD,"Instructor "_PSBINST(0)_" present.",PSBTRAN)
K PSB1,PSB2,PSB1A,PSB2A ;*83
Q
ERR(X,Y) ;
S X=$P("Business Logic Error^Data Validation Error",U,X)
S RESULTS($O(RESULTS(""),-1)+1)=X_": "_Y
S PSBMES($O(PSBMES(""),-1)+1)=X_": "_Y
Q
N PSBFDA,PSBIEN,PSBNOW
S PSBIEN="+1,"_DA_","
D NOW^%DTC S PSBNOW=%
D VAL(53.793,PSBIEN,.01,PSBCMT)
S PSBFDA(53.793,PSBIEN,.02)=DUZ
S PSBFDA(53.793,PSBIEN,.03)=PSBNOW
D FILEIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBML 14782 printed Oct 16, 2024@17:40:57 Page 2
PSBML ;BIRMINGHAM/EFC-BCMA MED LOG FUNCTIONS ;03/06/16 3:06pm
+1 ;;3.0;BAR CODE MED ADMIN;**6,3,4,9,11,13,25,45,33,52,70,72,79,94,83,98**;Mar 2004;Build 2
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ; Reference/IA
+4 ; ^DPT/10035
+5 ; DIC(42/10039
+6 ; DIC(42/2440
+7 ; File 200/10060
+8 ; EN^PSJBCMA3/3320
+9 ; $$SITE^VASITE/10112
+10 ; ^XUSEC(/10076
+11 ;
+12 ;*70 - store clinic name to admin location if exists.
+13 ; - add witness duz, dt/tm for high risk/alert drug, Order level
+14 ; HR code, and a witnessed y/n flag to MEDLOG file.
+15 ;*83 - store MRR code to DD multiple .06 field, to update AMRR xref
+16 ; - store Scheduled Removal time in a new field in 53.79
+17 ; - change offset of incoming array from 10th to 11th piece.
+18 ;
RPC(RESULTS,PSBHDR,PSBREC) ;BCMA MedLog Filing
+1 KILL PSBEDTFL
+2 SET PSBEDTFL=0
+3 ;Add PSBMES variable for PSB*3*52
NEW PSBORD,PSBTRAN,PSBFDA,PSBMES
+4 ;*70
NEW PSBCLIN,PSBWITN,PSBWITCM,PSBWITHR,PSBWITFL,LOC
+5 ;used for trigger xref code *83
NEW PSBACTN
+6 KILL PSBIEN,PSBHL7,%,PSBAUDIT,PSBINST
+7 SET PSBIEN=$PIECE(PSBHDR,U,1)
+8 SET PSBTRAN=$PIECE(PSBHDR,U,2)
SET PSBHL7=PSBTRAN
+9 SET PSBINST=$PIECE($GET(PSBHDR),U,3)
+10 ;*70 witness fields
+11 ;init witness duz var
SET PSBWITN=+$PIECE(PSBHDR,U,4)
+12 ;init witness comment
SET PSBWITCM=$PIECE(PSBHDR,U,5)
+13 ;init witness HR order level
SET PSBWITHR=+$PIECE(PSBHDR,U,6)
+14 ;init witnessed?
SET PSBWITFL=$SELECT(PSBWITN:1,1:0)
+15 IF PSBWITN=""
IF PSBWITHR=3
Begin DoDot:1
+16 SET RESULTS(0)=1
+17 SET RESULTS(1)="-1^A Witness is required, however Witness information was null."
End DoDot:1
QUIT
+18 ;PSB*3*45 We should be recording the first entry in the audit log.
+19 ;S PSBAUDIT=$S(PSBIEN="+1":0,1:1)
+20 SET PSBAUDIT=1
+21 DO NOW^%DTC
SET PSBNOW=%
+22 IF $DATA(^XUSEC("PSB STUDENT",DUZ))
IF PSBINST=""
SET RESULTS(0)=1
SET RESULTS(1)="-1^Instructor not present"
QUIT
+23 IF $DATA(^XUSEC("PSB STUDENT",DUZ))
IF '$DATA(^XUSEC("PSB INSTRUCTOR",PSBINST))
SET RESULTS(0)=1
SET RESULTS(1)="-1^Instructor doesn't have authority"
QUIT
+24 SET PSBINST(0)=$$GET1^DIQ(200,PSBINST_",",.01)
+25 IF PSBTRAN="ADD COMMENT"
DO COMMENT^PSBML1
QUIT
+26 IF PSBTRAN="PRN EFFECTIVENESS"
DO PRN^PSBML1
QUIT
+27 ;
+28 ;update medlog rec
UPD IF PSBTRAN="UPDATE STATUS"
Begin DoDot:1
+1 KILL PSBTAB,PSBUID
+2 ;var for trigger code for Variance calcs *83
SET PSBACTN=PSBREC(0)
+3 IF '$DATA(^PSB(53.79,PSBIEN))
Begin DoDot:2
+4 SET RESULTS(0)=1
+5 SET RESULTS(1)="-1^Administration is at an UNKNOWN STATUS"
End DoDot:2
QUIT
+6 DO UPDATED^PSBML2
End DoDot:1
QUIT
+7 ;
+8 ;edit Medlog rec
EDITML IF PSBTRAN="EDIT"
DO EDIT^PSBML2
QUIT
+1 ;
+2 ;SAGG
+3 NEW PSBWARD
SET PSBWARD=$GET(^DPT(+$GET(PSBREC(0)),.1),"UNKNOWN")
SET ^PSB("SAGG",PSBWARD,DT)=$GET(^PSB("SAGG",PSBWARD,DT))+1
+4 ;*70 save clinic name if exists before manipulating PSBREC(1) param
+5 SET PSBCLIN=$PIECE(PSBREC(1),U,2)
IF PSBCLIN=""
SET PSBCLIN=$SELECT($GET(PSBCLIEN):$PIECE($GET(^SC(+PSBCLIEN,0)),"^"),($GET(PSBCLORD)]""):PSBCLORD,1:"")
+6 SET PSBREC(1)=$PIECE(PSBREC(1),U)
+7 ;
+8 ;pre-existing psbrec(1) manipulation logic to *70
+9 IF PSBREC(1)?1U1";"1.6N
SET PSBREC(1)=$PIECE(PSBREC(1),";",1)_$EXTRACT(PSBREC(1))
+10 DO PSJ1^PSBVT(PSBREC(0),$PIECE(PSBREC(1),";",2)_$PIECE(PSBREC(1),";",1))
+11 SET PSBTAB=$PIECE(PSBREC(9),U,1)
SET PSBUID=$PIECE(PSBREC(9),U,2)
MEDP if PSBTRAN="MEDPASS"
Begin DoDot:1
+1 KILL PSBDIV,PSBON,PSBXDT,PSBYZ
+2 ;var for trigger code for Variance calcs *83
SET PSBACTN=PSBREC(3)
+3 ;add MRR flag to test *83
IF ((PSBDOSEF["PATCH")!(PSBMRRFL))
IF (PSBREC(3)="G")
Begin DoDot:2
+4 SET PSBXDT=""
FOR
SET PSBXDT=$ORDER(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXDT))
if PSBXDT=""
QUIT
Begin DoDot:3
+5 SET PSBYZ=""
FOR
SET PSBYZ=$ORDER(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXDT,PSBYZ))
if 'PSBYZ
QUIT
IF ("G"[$$GET1^DIQ(53.79,PSBYZ,.09,"I"))
Begin DoDot:4
+6 ;make generic verbiage *83
if ($$GET1^DIQ(53.79,PSBYZ,.09,"I")="G")
SET RESULTS(0)=1
SET RESULTS(1)="-1^Previous administration has not been removed. Administration canceled.^"
+7 if ($$GET1^DIQ(53.79,PSBYZ,.09,"I")="")&(($$GET1^DIQ(53.79,PSBYZ,.07,"I")'=DUZ)&('$DATA(^XUSEC("PSB MANAGER",DUZ))))
SET RESULTS(0)=1
SET RESULTS(1)="-1^Patch status ""*UNKNOWN*"". Administration canceled."
End DoDot:4
QUIT
End DoDot:3
if +$GET(RESULTS(1))<0
QUIT
End DoDot:2
if +$GET(RESULTS(1))<0
QUIT
+8 ;MOB
IF PSBREC(7)="BCMA/CPRS Interface Entry."
SET PSBNOW=PSBREC(5)
+9 FOR X=0:1:9
SET PSBREC(X)=$GET(PSBREC(X))
+10 IF PSBREC(1)?1U1";".N
SET PSBREC(1)=$PIECE(PSBREC(1),";",2)_$PIECE(PSBREC(1),";",1)
+11 IF PSBREC(1)["V"
IF +PSBREC(5)>0
IF +$PIECE(PSBREC(5),".",2)=0
IF PSBIVT'["P"
DO NOW^%DTC
SET PSBREC(5)=$PIECE(PSBREC(5),".",1)_"."_$PIECE(%,".",2)
+12 IF $PIECE(PSBREC(9),U,1)="IVTAB"
IF $PIECE(PSBREC(9),U,2)=""
SET PSBUID=$$GETWSID^PSBVDLU2(PSBREC(0),PSBREC(1))
+13 IF $PIECE(PSBREC(9),U,1)="PBTAB"
IF $PIECE(PSBREC(9),U,2)=""
IF PSBREC(1)'["U"
IF PSBREC(3)'="M"
IF PSBREC(3)'="R"
IF PSBREC(3)'="H"
SET PSBUID=$$GETWSID^PSBVDLU2(PSBREC(0),PSBREC(1))
+14 ;OnCal
+15 if PSBREC(2)="OC"
Begin DoDot:2
+16 SET X=$ORDER(^PSB(53.79,"AORD",PSBREC(0),PSBREC(1),""))
if X=""
QUIT
+17 SET Y=$ORDER(^PSB(53.79,"AORD",PSBREC(0),PSBREC(1),X,0))
+18 IF $PIECE(^PSB(53.79,Y,0),U,9)="G"&('$$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL"))
DO ERR(1,"On-Call already given")
End DoDot:2
+19 ;1x
+20 if PSBREC(2)="O"
Begin DoDot:2
+21 SET X=$ORDER(^PSB(53.79,"AORD",PSBREC(0),PSBREC(1),""))
if X=""
QUIT
+22 SET Y=$ORDER(^PSB(53.79,"AORD",PSBREC(0),PSBREC(1),X,0))
+23 IF $PIECE(^PSB(53.79,Y,0),U,9)="G"
DO ERR(1,"One Time already Given")
End DoDot:2
+24 ;PRN
+25 IF PSBREC(2)="P"
IF PSBREC(3)'="M"
IF $PIECE(PSBREC(9),U,1)'="IVTAB"
Begin DoDot:2
+26 IF PSBREC(6)=""
DO ERR(1,"PRN Medications MUST Have a PRN Reason")
+27 IF PSBREC(5)]""
DO ERR(1,"PRN Orders don't have scheduled times")
+28 IF PSBREC(3)'="G"
DO ERR(1,"PRN Orders cannot be marked NOT Given")
End DoDot:2
+29 ;Cnt
+30 IF PSBREC(2)="C"
IF PSBTAB'="IVTAB"
Begin DoDot:2
+31 if PSBREC(5)=""
DO ERR(1,"Continuous Order needs admin time")
+32 if PSBREC(6)]""
DO ERR(1,"No PRN Reason allowed on Continuous Orders")
End DoDot:2
+33 IF PSBREC(2)="C"
IF $DATA(^PSB(53.79,"AORD",PSBREC(0),PSBREC(1),+PSBREC(5)))
IF PSBIEN="+1"
Begin DoDot:2
+34 SET PSBSIEN=$ORDER(^PSB(53.79,"AORD",PSBREC(0),PSBREC(1),PSBREC(5),""))
+35 IF PSBSIEN]""
IF '(($PIECE(^PSB(53.79,PSBSIEN,0),U,7)=DUZ)!($DATA(^XUSEC("PSB MANAGER",DUZ))))
SET PSBSIEN=""
+36 IF PSBSIEN']""
SET RESULTS(0)=2
SET RESULTS(1)="-2^Error Filing Transaction MEDPASS"
SET RESULTS(2)="The PSB MANAGER key is required to modify this scheduled admin"
QUIT
+37 if $PIECE(^PSB(53.79,PSBSIEN,0),U,9)'="N"
Begin DoDot:3
+38 KILL PSBINCX
IF $PIECE(^PSB(53.79,PSBSIEN,0),U,9)=""
SET PSBINCX=PSBSIEN
LOCK +^PSB(53.79,PSBINCX):1
if '$TEST
QUIT
LOCK -^PSB(53.79,PSBINCX)
+39 SET Y=$PIECE(^PSB(53.79,PSBSIEN,0),U,6)
DO DD^%DT
SET PSBADMAT=Y
+40 SET PSBADMBY=$$GET1^DIQ(200,$PIECE(^PSB(53.79,PSBSIEN,0),U,7),.01,)
+41 SET RESULTS(0)=3
SET RESULTS(1)="-2^Error Filing Transaction MEDPASS"
+42 SET RESULTS(2)="Continuous Administration Date/Time already on file."
+43 SET RESULTS(3)="Administered by "_PSBADMBY_" at "_PSBADMAT_"."
+44 IF $DATA(XWB)
SET RESULTS(0)=RESULTS(0)+2
SET RESULTS(4)=" "
SET RESULTS(5)=" VDL will now be updated."
End DoDot:3
End DoDot:2
KILL PSBADMBY,PSBADMAT
if PSBSIEN=""
QUIT
if $PIECE(^PSB(53.79,PSBSIEN,0),U,9)'="N"
QUIT
+45 ;Non Given
+46 IF PSBREC(3)'="G"
IF PSBREC(3)'="M"
IF PSBUID'["V"
IF PSBUID'["W"
Begin DoDot:2
+47 IF PSBREC(7)=""
IF PSBTAB'="IVTAB"
DO ERR(1,"Comment needed if Not Marked Given")
+48 IF PSBREC(7)=""
IF PSBTAB="IVTAB"
DO ERR(1,"Comment needed if Not Marked Completed")
End DoDot:2
+49 ;.3
if PSBREC(3)="H"
SET PSBREC(7)="Held: "_PSBREC(7)
+50 ;.3
if PSBREC(3)="R"
SET PSBREC(7)="Refused: "_PSBREC(7)
+51 ;.3
if PSBREC(3)="S"
SET PSBREC(7)="Stopped: "_PSBREC(7)
+52 ;Valid?
+53 ;do UPDATE
IF $GET(PSBSIEN)'=""
IF $DATA(^PSB(53.79,PSBSIEN,0))
IF $PIECE(^PSB(53.79,PSBSIEN,0),U,9)="N"
SET PSBIEN=+PSBSIEN_","
SET $PIECE(PSBHDR,U)=PSBIEN
SET PSBTRAN="UPDATE STATUS"
SET PSBAUDIT=1
+54 ;New fields only?
if PSBIEN="+1"
Begin DoDot:2
+55 ;Patn
DO VAL(53.79,PSBIEN,.01,"`"_PSBREC(0))
+56 ;Ward Room/Bed LOC
SET LOC=$GET(^DPT(PSBREC(0),.1))_" "_$GET(^(.101))
+57 ;If clinic order use clin name *70
if PSBCLIN]""
SET LOC=PSBCLIN
+58 ;Patn Location LOC
DO VAL(53.79,PSBIEN,.02,LOC)
+59 if $GET(^DPT(PSBREC(0),.1))'=""
Begin DoDot:3
+60 SET Y=$ORDER(^DIC(42,"B",$GET(^DPT(PSBREC(0),.1)),""))
SET Y=$$GET1^DIQ(42,Y,.015,"I")
SET PSBDIV=$$SITE^VASITE(DT,Y)
+61 ;Div
DO VAL(53.79,PSBIEN,.03,"`"_$PIECE(PSBDIV,U,1))
End DoDot:3
+62 ;Entered dt/tm
DO VAL(53.79,PSBIEN,.04,PSBNOW)
+63 ;Entered by duz
DO VAL(53.79,PSBIEN,.05,"`"_DUZ)
+64 ;Admin dt/tm
DO VAL(53.79,PSBIEN,.06,PSBNOW)
+65 ;Admin By duz
DO VAL(53.79,PSBIEN,.07,"`"_DUZ)
+66 ;Orderable Item
DO VAL(53.79,PSBIEN,.08,"`"_PSBREC(4))
+67 ;Ord file 55 IEN
DO VAL(53.79,PSBIEN,.11,PSBREC(1))
+68 ;Ord Schd Type
DO VAL(53.79,PSBIEN,.12,PSBREC(2))
+69 ;Schd Admin dt/tm
DO VAL(53.79,PSBIEN,.13,PSBREC(5))
+70 IF $PIECE($GET(PSBREC(10)),".",2)]""
Begin DoDot:3
+71 ;Schd Remove dt/tm
DO VAL(53.79,PSBIEN,.17,PSBREC(10))
End DoDot:3
+72 ;IV Bag ID
if PSBTAB'="UDTAB"
DO VAL(53.79,PSBIEN,.26,PSBUID)
+73 ;Schd Admdt/tm null
if PSBTAB="IVTAB"
DO VAL(53.79,PSBIEN,.13,"")
+74 ;UD Dosage
if PSBREC(1)?.N1"U"
DO VAL(53.79,PSBIEN,.15,PSBDOSE)
+75 ;IV Infuse Rate
if PSBREC(1)?.N1"V"
DO VAL(53.79,PSBIEN,.35,PSBIFR)
+76 ;Witness logic and Give? *70
IF PSBWITHR>1
IF (PSBREC(3)="G")!(PSBREC(3)="I")
Begin DoDot:3
+77 ;Witness dt/time
if PSBWITN
DO VAL(53.79,PSBIEN,.28,PSBNOW)
+78 ;Witness duz
if PSBWITN
DO VAL(53.79,PSBIEN,.29,"`"_PSBWITN)
+79 ;Witness comment
if PSBWITCM]""
DO VAL(53.79,PSBIEN,.31,PSBWITCM)
+80 ;Witness HR ord code
DO VAL(53.79,PSBIEN,.32,PSBWITHR)
+81 ;Witnessed? flag
DO VAL(53.79,PSBIEN,.33,PSBWITFL)
End DoDot:3
End DoDot:2
+82 ;
+83 ;Overwrite fields below, rec already exists
+84 ;Gvn/Completed?
IF PSBREC(3)="G"!(PSBREC(3))="C"
Begin DoDot:2
+85 ;Admin dt/tm
DO VAL(53.79,PSBIEN,.06,PSBNOW)
+86 ;Admin By duz
DO VAL(53.79,PSBIEN,.07,"`"_DUZ)
End DoDot:2
+87 ; set Derm/Inj site fields *83
+88 IF PSBREC(8)]""
Begin DoDot:2
+89 NEW SITETXT,SITECD
+90 SET SITETXT=$PIECE(PSBREC(8),"|",1)
SET SITECD=$PIECE(PSBREC(8),"|",2)
+91 ;If dermal, else assume inj site
IF SITECD="D"
Begin DoDot:3
+92 ;Dermal site
DO VAL(53.79,PSBIEN,.18,SITETXT)
End DoDot:3
+93 IF '$TEST
Begin DoDot:3
+94 ;Inject site
DO VAL(53.79,PSBIEN,.16,SITETXT)
End DoDot:3
End DoDot:2
+95 ;
+96 ;AStats
if '$GET(PSBMMEN)
DO VAL(53.79,PSBIEN,.09,PSBREC(3))
+97 ;PRN reason?
IF PSBREC(6)]""
Begin DoDot:2
+98 ;reason dt/tm
DO VAL(53.79,PSBIEN,.21,$PIECE(PSBREC(6),U))
+99 ;PRN reason
DO VAL(53.79,PSBIEN,.27,$PIECE(PSBREC(6),U,2))
End DoDot:2
+100 if PSBREC(7)]""
Begin DoDot:2
+101 ;Comment
DO VAL(53.793,"+2,"_PSBIEN,.01,PSBREC(7))
+102 ;comnt person duz
DO VAL(53.793,"+2,"_PSBIEN,.02,"`"_DUZ)
+103 ;comnt dt/time
DO VAL(53.793,"+2,"_PSBIEN,.03,PSBNOW)
End DoDot:2
+104 ;
+105 ;DD/SOL/ADD
+106 ;given/action stat codes?
IF PSBREC(3)="G"!(PSBREC(3)="I")!(PSBREC(3)="H")!(PSBREC(3)="R")!(PSBREC(3)="M")
Begin DoDot:2
+107 IF PSBTRAN="UPDATE STATUS"
KILL ^PSB(53.79,+PSBIEN,.5),^PSB(53.79,+PSBIEN,.6),^PSB(53.79,+PSBIEN,.7)
+108 ;move DD segments to element 11..n No longer 10th *83
+109 KILL PSBCNT,PSBIENS
+110 FOR PSBCNT=11:1
if '$DATA(PSBREC(PSBCNT))
QUIT
Begin DoDot:3
+111 SET Y=$PIECE(PSBREC(PSBCNT),U)
+112 SET PSBDD=$SELECT(Y="DD":53.795,Y="ADD":53.796,Y="SOL":53.797,1:0)
+113 if 'PSBDD
QUIT
+114 SET PSBIENS="+"_PSBCNT_","_PSBIEN
+115 DO VAL(PSBDD,PSBIENS,.01,"`"_$PIECE(PSBREC(PSBCNT),U,2))
+116 DO VAL(PSBDD,PSBIENS,.02,$PIECE(PSBREC(PSBCNT),U,3))
+117 if PSBDD=53.795
DO VAL(PSBDD,PSBIENS,.02,$PIECE(PSBREC(PSBCNT),U,3))
+118 ;Store units in Units ordered field, PSB*3*72
if PSBDD=53.796!(PSBDD=53.797)
DO VAL(PSBDD,PSBIENS,.02,$PIECE(PSBREC(PSBCNT),U,4))
+119 ;only store units given when infusing or given, PSB*3*72
if PSBREC(3)="G"!(PSBREC(3)="I")
DO VAL(PSBDD,PSBIENS,.03,$PIECE(PSBREC(PSBCNT),U,4))
+120 if (PSBTAB="UDTAB")!(PSBTAB="PBTAB")
DO VAL(PSBDD,PSBIENS,.04,$EXTRACT($PIECE(PSBREC(PSBCNT),U,5),1,40))
+121 ;HR ind *70
DO VAL(PSBDD,PSBIENS,.05,$PIECE(PSBREC(PSBCNT),U,7))
+122 ;.06 field only valid for Unit dose DD type, not for IV's *83
+123 ;MRR
if PSBDD=53.795
DO VAL(PSBDD,PSBIENS,.06,$PIECE(PSBREC(PSBCNT),U,8))
End DoDot:3
End DoDot:2
+124 ;Modify Filing Transaction Medpass error message too inclde details - PSB*3*52
+125 IF $ORDER(RESULTS(""))
Begin DoDot:2
+126 NEW PSBERR
+127 IF $DATA(PSBMES)
Begin DoDot:3
+128 SET RESULTS(1)="-2^***Your documentation is NOT being recorded in the patient record.***"
SET RESULTS(2)=""
+129 SET RESULTS(3)="Please write down the information (below) AND contact your BCMA Coordinator or IT Support for assistance:"
SET RESULTS(4)=""
+130 SET RESULTS(5)="Error(s) Filing Transaction MEDPASS"
End DoDot:3
+131 SET PSBERR=0
FOR
SET PSBERR=$ORDER(PSBMES(PSBERR))
if PSBERR=""
QUIT
Begin DoDot:3
+132 SET RESULTS($ORDER(RESULTS(""),-1)+1)=PSBMES(PSBERR)
SET RESULTS(0)=$ORDER(RESULTS(""),-1)
End DoDot:3
End DoDot:2
QUIT
+133 ;
+134 DO FILEIT
+135 ;
+136 ;PSB*3*33
+137 ;1x exp?
if ((PSBREC(2)="O")!($$ONE^PSJBCMA(PSBREC(0),PSBREC(1))="O"))&(PSBREC(3)="G")
DO EXPIRE^PSBML1
+138 ;D:(PSBREC(2)="O")&(PSBREC(3)="G") EXPIRE^PSBML1 ;1x exp? ;Remove second call, which will always be made if above call is true, PSB*3*98
+139 IF $PIECE(RESULTS(0),U,1)=1
IF PSBTAB'="UDTAB"
IF PSBUID]""
IF PSBUID'["WS"
SET PSBON=+PSBREC(1)
DO EN^PSJBCMA3(PSBREC(0),PSBON,PSBUID,PSBREC(3),PSBNOW)
End DoDot:1
+140 QUIT
BCBU ;HL7,NatContng
+1 if +$GET(RESULTS(0))'>0
QUIT
+2 NEW PSBIEN1
SET PSBIEN1=$SELECT($PIECE(PSBIEN,",",2)'="":+$PIECE(PSBIEN,",",2),$GET(PSBIEN)="+1":PSBIEN(1),1:+$GET(PSBIEN))
+3 IF $GET(PSBIEN1)=""
SET RESULTS(0)=1
SET RESULTS(1)="-1^Contingency NOT processed"
QUIT
+4 IF $GET(PSBIEN)="+1"
SET PSBHL7="MEDPASS"
+5 IF '$TEST
if $GET(PSBHL7)=""
SET PSBHL7="UPDATE STATUS"
+6 if ('$DATA(Y(0))!($GET(Y(0))="SAVE")!($GET(Y(0))="YES"))
DO EN^PSBSVHL7(+PSBIEN1,PSBHL7)
DO MEDL^ALPBCBU(+PSBIEN1)
KILL PSBHL7
+7 ;<<HDR-VDEF(frm *3)
+8 QUIT
VAL(PSBDD,PSBIEN,PSBFLD,PSBVAL) ;
+1 KILL ^TMP("DIERR",$JOB),PSBRET
+2 DO VAL^DIE(PSBDD,PSBIEN,PSBFLD,"F",PSBVAL,.PSBRET,"PSBFDA")
+3 IF PSBRET="^"
FOR X=0:0
SET X=$ORDER(^TMP("DIERR",$JOB,X))
if 'X
QUIT
DO ERR(2,^TMP("DIERR",$JOB,X)_": "_$GET(^(X,"TEXT",1),"**"))
+4 KILL ^TMP("DIERR",$JOB),PSBRET
+5 QUIT
FILEIT ;Updt
+1 KILL Z,X,PSB1,PSB2
+2 NEW PSBMSG,PSBAUD
+3 SET (PSB1,PSB2)=""
+4 DO APATCH^PSBML3
+5 ;*83
DO AMRR^PSBML3
+6 DO CLEAN^DILF
+7 DO RESETADM^PSBUTL
+8 DO UPDATE^DIE("","PSBFDA","PSBIEN","PSBMSG")
+9 IF '$GET(PSBMMEN)
SET X=+PSBIEN
IF $FIND("HR",$PIECE(^PSB(53.79,X,0),U,9))>1
FOR Y=.5,.6,.7
SET Z=0
FOR
SET Z=$ORDER(^PSB(53.79,+X,Y,Z))
if +Z=0
QUIT
SET $PIECE(^PSB(53.79,+X,Y,Z,0),U,3)=0
+10 IF $DATA(PSBMSG("DIERR"))
SET RESULTS(0)=1
SET RESULTS(1)="-1^"_PSBMSG("DIERR",1)_": "_PSBMSG("DIERR",1,"TEXT",1)
QUIT
+11 IF $GET(PSB1)]""
XECUTE PSB1
IF $GET(PSB2)]""
XECUTE PSB2
+12 ;*83
IF $GET(PSB1A)]""
XECUTE PSB1A
IF $GET(PSB2A)]""
XECUTE PSB2A
+13 IF $DATA(PSBHDR)
if "NHMR"[$PIECE(^PSB(53.79,$SELECT($PIECE(PSBHDR,"^",1)="+1"
Begin DoDot:1
+14 NEW PSBINDX
SET PSBINDX=$SELECT($PIECE(PSBHDR,"^",1)="+1":PSBIEN(1),1:+PSBIEN)
+15 KILL ^PSB(53.79,"APATCH",$PIECE(^PSB(53.79,PSBINDX,0),U),$PIECE(^PSB(53.79,PSBINDX,0),U,6),PSBINDX)
End DoDot:1
+16 SET RESULTS(0)=1
SET RESULTS(1)="1^Data Successfully Filed^"_$SELECT($GET(PSBIEN(1))'="":$GET(PSBIEN(1)),1:+$GET(PSBIEN))
+17 ;NatContng
DO BCBU
+18 ;
Begin DoDot:1
+19 NEW X,DIC
+20 ;should handle all BCMA Med Log events for VPR
SET X="PSB EVSEND VPR"
SET DIC=101
DO EN^XQOR
End DoDot:1
+21 IF $GET(PSBINST,0)
SET PSBAUD=$SELECT($PIECE(PSBHDR,"^",1)="+1":PSBIEN(1),1:$PIECE(PSBHDR,"^",1))
DO AUDIT^PSBMLU(PSBAUD,"Instructor "_PSBINST(0)_" present.",PSBTRAN)
+22 ;*83
KILL PSB1,PSB2,PSB1A,PSB2A
+23 QUIT
ERR(X,Y) ;
+1 SET X=$PIECE("Business Logic Error^Data Validation Error",U,X)
+2 SET RESULTS($ORDER(RESULTS(""),-1)+1)=X_": "_Y
+3 SET PSBMES($ORDER(PSBMES(""),-1)+1)=X_": "_Y
+4 QUIT
+1 NEW PSBFDA,PSBIEN,PSBNOW
+2 SET PSBIEN="+1,"_DA_","
+3 DO NOW^%DTC
SET PSBNOW=%
+4 DO VAL(53.793,PSBIEN,.01,PSBCMT)
+5 SET PSBFDA(53.793,PSBIEN,.02)=DUZ
+6 SET PSBFDA(53.793,PSBIEN,.03)=PSBNOW
+7 DO FILEIT
+8 QUIT
