- 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 Jan 18, 2025@02:41:20 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