PSBML2 ;BIRMINGHAM/TEJ-BCMA UTILITY TO EDIT THE PSB MED LOG ;03/06/16 3:06pm
;;3.0;BAR CODE MED ADMIN;**3,18,22,23,13,45,42,70,72,83,99,121,124,130**;Mar 2004;Build 1
;Per VA Directive 6402, this routine should not be modified
; Reference/IA
; EN^PSJBCMA3/3320
; ENE^PSJBCMA4/3416
; ENR^PSJBCMA4/3416
;
;*70 - update Witness if present and Giving now as an updated, could
; mean undo given or a hold/refused was done first.
;*83 - store MRR code to DD multiple .06 field, to update AMRR xref
;
EDIT ;
K RESULTS S PSBEDIEN=PSBIEN_",",RESULTS(0)=0
I $G(PSBREC(7))']"" S RESULTS(0)=1,RESULTS(1)="-1^Data NOT filed - Comment is required" Q
D
.S PSBEDTFL=1,PSBMODS=0,PSBREC(1)=""
.D:PSBREC(4)]"" VAL^PSBML(53.79,PSBEDIEN,.06,PSBREC(4))
.I (PSBREC(0)="N") D
..I ($$GET1^DIQ(53.79,PSBEDIEN,.11)["V") F PSBX=1:1:6 S PSBREC(PSBX)=""
.I ("NHR"[PSBREC(0)),$D(^PSB(53.79,+PSBEDIEN,.2)) D
..; Audit PRN
..D:$P(^PSB(53.79,+PSBEDIEN,.2),U,2)]"" AUDIT^PSBUTL(+PSBEDIEN,53.79,.22,$P(^PSB(53.79,+PSBEDIEN,.2),U,2),"K")
..I ($P(^PSB(53.79,+PSBEDIEN,0),U,9)="G")!($P(^PSB(53.79,+PSBEDIEN,0),U,9)="I") D
...I $D(^PSB(53.79,"APRN",$P(^PSB(53.79,+PSBEDIEN,0),U,1),$P(^PSB(53.79,+PSBEDIEN,0),U,6),+PSBEDIEN)) D
....K ^PSB(53.79,"APRN",$P(^PSB(53.79,+PSBEDIEN,0),U,1),$P(^PSB(53.79,+PSBEDIEN,0),U,6),+PSBEDIEN) K ^PSB(53.79,+PSBEDIEN,.2)
.I ("NHR"'[PSBREC(0)) D:$G(PSBREC(5))]"" VAL^PSBML(53.79,PSBEDIEN,.21,$G(PSBREC(5))) D:$G(PSBREC(6))]"" VAL^PSBML(53.79,PSBEDIEN,.22,$G(PSBREC(6)))
.I +$G(RESULTS(0))<0 S RESULTS(1)="-1^Data NOT filed - "_$P(RESULTS(0),U,2),RESULTS(0)=1 Q
.D:$D(^PSB(53.79,+PSBEDIEN,.2)) VAL^PSBML(53.79,PSBEDIEN,.21,$G(PSBREC(5))),VAL^PSBML(53.79,PSBEDIEN,.22,$G(PSBREC(6)))
.D VAL^PSBML(53.793,"+2,"_PSBIEN,.01,PSBREC(7))
.D VAL^PSBML(53.793,"+2,"_PSBIEN,.02,"`"_DUZ)
.D VAL^PSBML(53.793,"+2,"_PSBIEN,.03,PSBNOW)
Q:+$G(RESULTS(1))<0
S PSBMODS=$$CHANGE^PSBML3(.PSBREC,PSBEDIEN)
D:PSBMODS UPDATED
D:('$G(PSBERR))&('$G(PSBMODS)) FILEIT^PSBML
; Audit DD
I $D(PSBORDMD) S (PSBXY,PSBXZ)="" D
.F S PSBXY=$O(PSBORDMD(PSBXY)) Q:PSBXY="" S PSBFDAX=$S(PSBXY=.6:53.796,PSBXY=.7:53.797,1:53.795) F S PSBXZ=$O(PSBORDMD(PSBXY,PSBXZ)) Q:PSBXZ="" D
..S PSBXACT="",PSBXACT=$G(PSBORDMD(PSBXY,PSBXZ,0))
..D:PSBXACT["ADD" AUDIT^PSBUTL(+PSBEDIEN,PSBFDAX,.01,PSBXZ,"S") D:PSBXACT["DELETE" AUDIT^PSBUTL(+PSBEDIEN,PSBFDAX,.01,PSBXZ,"K")
;
K PSBORDMD,PSBCHNG,PSBDDX,PSBEDTFL,PSBEDIEN,PSBFILED
Q
;
UPDATED ;
N PSBADD
S PSBIEN=PSBIEN_",",PSBXPTCH=0
S PSBRECNO=$S(PSBEDTFL:8,1:4)
I "^G^N^H^R^RM^S^C^I^M^"[(U_PSBREC(0)_U) D
.D:('PSBEDTFL) VAL^PSBML(53.79,PSBIEN,.06,PSBNOW)
.D:$D(PSBREC(4,0)) VAL^PSBML(53.79,PSBIEN,.06,PSBREC(4))
.D VAL^PSBML(53.79,PSBIEN,.07,"`"_DUZ)
.D:('PSBEDTFL)!($G(PSBREC(0,0))) VAL^PSBML(53.79,PSBIEN,.09,PSBREC(0))
.I $G(PSBREC(3))]"" D VAL^PSBML(53.79,PSBIEN,.26,PSBREC(3))
I $D(PSBREC(PSBRECNO)) D:($G(PSBREC(0))="G")&($P(PSBREC(PSBRECNO),U,5)["PATCH") Q:+$G(RESULTS(1))<0
.Q:$$GET1^DIQ(53.79,PSBIEN,.09,"I")=""
.S PSBXDFN=$$GET1^DIQ(53.79,PSBIEN,.01,"I")
.S PSBXORN=$$GET1^DIQ(53.79,+PSBIEN,.11,"I")
.S PSBXDT="" F S PSBXDT=$O(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT)) Q:PSBXDT="" D Q:+$G(RESULTS(1))<0
..S PSBYZ="" F S PSBYZ=$O(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT,PSBYZ)) Q:'PSBYZ I ($$GET1^DIQ(53.79,PSBYZ,.09,"I")="G"),(PSBYZ'=+PSBIEN) S RESULTS(0)=1,RESULTS(1)="-1^Previous Patch has not been removed. Administration canceled." Q
S:'$D(PSBXDFN) PSBXDFN=$$GET1^DIQ(53.79,PSBIEN,.01,"I"),PSBXORN=$$GET1^DIQ(53.79,+PSBIEN,.11,"I")
I $G(PSBREC(3))']"",$G(PSBREC(0))="G",$P($G(PSBREC(4)),U)'="DD",$P($G(PSBREC(8)),U)'="DD" S PSBUID=$$GETWSID^PSBVDLU2(+PSBXDFN,+PSBXORN) D VAL^PSBML(53.79,PSBIEN,.26,PSBUID)
;
D:$G(PSBREC(0))="N"
.I (PSBREC(0)="N"),($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G") S PSBREC(1)="Undo Given: "_$G(PSBREC(1))
.I ((PSBREC(0)="N")!(PSBREC(0)="G")),($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM") S PSBREC(1)="Undo Remove: "_$G(PSBREC(1))
.; Undo PRN
.I $D(^PSB(53.79,+PSBIEN,.2)) D
..I $P(^PSB(53.79,+PSBIEN,0),U,9)="G"!($P(^PSB(53.79,+PSBIEN,0),U,9)="I") D VAL^PSBML(53.79,PSBIEN,.21,"@") D ;Use BCMA Edit function to delete PRN Reason Field
...N DIK,DA
...I $$GET1^DIQ(53.79,PSBIEN_",",.22)]"" D VAL^PSBML(53.79,PSBIEN,.22,"@"),VAL^PSBML(53.79,PSBIEN,.23,"@"),VAL^PSBML(53.79,PSBIEN,.24,"@"),VAL^PSBML(53.79,PSBIEN,.25,"@") ;Use BCMA Edit function to delete PRN Effectiveness fields
...S DIK(1)=".12",DA=+PSBIEN,DIK="^PSB(53.79,"_DA_"," D EN2^DIK ;Use FM to properly delete order status and clean up "APRN" cross reference,PSB*3*72
..D:$$GET1^DIQ(53.79,PSBIEN_",",.27)=1 VAL^PSBML(53.79,PSBIEN,.27,"@") ;Use BCMA Edit function to delete PRN Reason Flag field, PSB*3*72
D:$G(PSBREC(1))]""
.S:PSBREC(0)="H" PSBREC(1)="Held: "_PSBREC(1)
.S:PSBREC(0)="R" PSBREC(1)="Refused: "_PSBREC(1)
.S:PSBREC(0)="RM" PSBREC(1)="Removed: "_PSBREC(1)
.I $D(PSBFDA(53.793,"+2,"_PSBIEN,.01)) S PSBREC(1)=PSBREC(1)_(PSBFDA(53.793,"+2,"_PSBIEN,.01))
.D VAL^PSBML(53.793,"+2,"_PSBIEN,.01,PSBREC(1)),VAL^PSBML(53.793,"+2,"_PSBIEN,.02,"`"_DUZ),VAL^PSBML(53.793,"+2,"_PSBIEN,.03,PSBNOW)
S PSBXDFN=$$GET1^DIQ(53.79,PSBIEN,.01,"I")
I ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM"),((PSBREC(0)="N")!(PSBREC(0)="G")) D
.I '(($D(^XUSEC("PSB MANAGER",DUZ)))!($$GET1^DIQ(53.79,+PSBIEN,.07,"I")=DUZ)) S RESULTS(0)=1,RESULTS(1)="-1^Verify PSB MANAGER allocation" Q
.S PSBXPTCH=1,PSBYY="",PSBGIVEN=0 F S PSBYY=$O(^PSB(53.79,+PSBIEN,.9,PSBYY),-1) Q:'PSBYY Q:(+$G(RESULTS(0))<0) Q:PSBGIVEN S PSBXDAT=$G(^(PSBYY,0)) D
..;PSB*3*45 Should be checking if action status changed to GIVEN
..I $P(PSBXDAT,"^",4)["GIVEN" D
...S PSBXDATE=$P(^PSB(53.79,+PSBIEN,.9,PSBYY,0),U)
...S PSBXORN=$$GET1^DIQ(53.79,+PSBIEN,.11,"I")
...S PSBYX=(PSBYY-2) I (PSBYX)>0 I ^PSB(53.79,+PSBIEN,.9,PSBYX,0)["ACTION DATE/TIME '" S PSBXDATE=$P(^PSB(53.79,+PSBIEN,.9,PSBYX,0),"'",2),X=$P(PSBXDATE,"@"),%DT="" D ^%DT S PSBXDATE=Y_"."_$TR($P(PSBXDATE,"@",2),":")
...S PSBXDT="" F S PSBXDT=$O(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT)) Q:PSBXDT="" D Q:+$G(RESULTS(1))<0
....S PSBYZ="" F S PSBYZ=$O(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT,PSBYZ)) Q:'PSBYZ I ($$GET1^DIQ(53.79,PSBYZ,.09,"I")="G"),(PSBYZ'=+PSBIEN) S RESULTS(0)=1,RESULTS(1)="-1^Cannot UNDO! Order has GIVEN patch" Q
...I '(+$G(RESULTS(1))<0) D S PSBGIVEN=1
....;PSB*3*45 Added PSBLSTG for the last user who gave the patch. this will be logged in order to undo multiple removed.
....S PSBLSTG=$P(PSBXDAT,"^",2),I="" F S I=$O(^PSB(53.79,+PSBIEN,.9,I),-1) Q:'I I $P(^PSB(53.79,+PSBIEN,.9,I,0),"^",4)["GIVEN" D Q
.....S PSBLSTG=$S($P($G(PSBXDAT),"^",5):$P(PSBXDAT,"^",5),1:$P(PSBXDAT,"^",2))
....D VAL^PSBML(53.79,PSBIEN,.06,PSBXDATE),VAL^PSBML(53.79,PSBIEN,.07,"`"_PSBLSTG),VAL^PSBML(53.79,PSBIEN,.09,"G") K PSBLSTG
..D:('(+$G(RESULTS(1))<0))&('PSBGIVEN)&($G(PSBXPTCH))&(PSBYY'>1)
...S PSBXDATE=$P(^PSB(53.79,+PSBIEN,.9,PSBYY,0),"'",2),X=$P(PSBXDATE,"@"),%DT="" D ^%DT S PSBXDATE=Y_"."_$TR($P(PSBXDATE,"@",2),":")
...D VAL^PSBML(53.79,PSBIEN,.06,PSBXDATE),VAL^PSBML(53.79,PSBIEN,.07,"`"_$$GET1^DIQ(53.79,+PSBIEN,.07,"I")),VAL^PSBML(53.79,PSBIEN,.09,"G") S PSBGIVEN=1
Q:(+$G(RESULTS(1))<0)
I PSBEDTFL,$G(PSBGIVEN),PSBXPTCH S PSBREC(0)="G",PSBUNTSG=$P(PSBREC(8),U,4) D VAL^PSBML(53.795,(1_","_PSBIEN),.03,$S(PSBUNTSG'=0:PSBUNTSG,1:1)) K PSBXPTCH
;Set or Del Derm/Inj site fields *83
I PSBREC(0)="N",PSBREC(1)["Undo Given" D ;Del site, Undo Give
.D VAL^PSBML(53.79,PSBIEN,.16,"@")
.D VAL^PSBML(53.79,PSBIEN,.18,"@")
I PSBREC(0)="G",$G(PSBREC(2))]"" D ;Set site
.N SITETXT,SITECD
.S SITETXT=$P(PSBREC(2),"|",1),SITECD=$P(PSBREC(2),"|",2)
.I SITECD="D" D
..D VAL^PSBML(53.79,PSBIEN,.18,SITETXT) ;Dermal site
.E D
..D VAL^PSBML(53.79,PSBIEN,.16,SITETXT) ;Inject site
.;
S PSBOLDUZ=$P(^PSB(53.79,+PSBIEN,0),U,7),PSBOLSTS=$P(^PSB(53.79,+PSBIEN,0),U,9)
;
;DD/SOL/ADD validate/load array logic begins
I $G(PSBREC(PSBRECNO))]"" D
.I PSBREC(0)="G"!(PSBREC(0)="I")!(PSBREC(0)="H")!(PSBREC(0)="R")!(PSBREC(0)="M") D ; Only if gvn or infus
..Q:(PSBEDTFL)&('$G(PSBCHNG))
..F PSBCNT=PSBRECNO: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
...I $G(PSBCHNG) D
....I $D(PSBFIND(PSBCNT)) S PSBIENS=$QS($Q(PSBFIND(PSBCNT)),2)_","_PSBIEN
....I '$D(PSBFIND(PSBCNT)) S PSBIENS="+1,"_PSBIEN
....D VAL^PSBML(PSBDD,PSBIENS,.01,"`"_$P(PSBREC(PSBCNT),U,2))
....D:PSBDD=53.795 VAL^PSBML(PSBDD,PSBIENS,.02,$P(PSBREC(PSBCNT),U,3))
....I '$P(PSBREC(PSBCNT),U,4),PSBREC(0)="I",((PSBDD=53.796)!(PSBDD=53.797)) S $P(PSBREC(PSBCNT),U,4)=$$GET1^DIQ(PSBDD,PSBIENS_",",.02) ;Store Units administered when infused, PSB*3*99
....I (PSBDD=53.796!(PSBDD=53.797))&($P(PSBREC(PSBCNT),U,4)) D VAL^PSBML(PSBDD,PSBIENS,.02,$P(PSBREC(PSBCNT),U,4)) ;Store units in Units ordered field, PSB*3*72
....D:PSBREC(0)="G"!(PSBREC(0)="I") VAL^PSBML(PSBDD,PSBIENS,.03,$P(PSBREC(PSBCNT),U,4)) ;only store units given when infusing or given, PSB*3*72
....D:PSBDD=53.795 VAL^PSBML(PSBDD,PSBIENS,.04,$P(PSBREC(PSBCNT),U,5))
....D VAL^PSBML(PSBDD,PSBIENS,.05,$P(PSBREC(PSBCNT),U,6)) ;HR *70
....D:PSBDD=53.795 VAL^PSBML(PSBDD,PSBIENS,.06,$P(PSBREC(PSBCNT),U,7)) ;MRR *83
.I ('PSBEDTFL)!((PSBREC(0)'="G")&($$GET1^DIQ(53.79,PSBIEN,.09,"I")="G")) D
..S (PSBDCNT,PSBACNT,PSBSCNT)=0,PSBADD=3 F PSBCNT=PSBRECNO: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 @("PSB"_$E(Y)_"CNT")=@("PSB"_$E(Y)_"CNT")+1
...S PSBIENS=(@("PSB"_$E(Y)_"CNT"))_","_PSBIEN
...I '$$GET1^DIQ(PSBDD,PSBIENS,.01,"I") S PSBIENS="+"_PSBADD_","_PSBIEN,PSBADD=PSBADD+1
...;Clear old units, PSB*3*99
...I Y="DD",(PSBREC(0)="G"!(PSBREC(0)="RM")) D
....S PSBMLT=1 F S PSBMLT=$O(^PSB(53.79,+PSBIEN,.5,PSBMLT)) Q:'PSBMLT D
.....I $G(PSBFDA(PSBDD,PSBMLT_","_PSBIEN,.01))="" D VAL^PSBML(PSBDD,PSBMLT_","_PSBIEN,.01,"@")
...I '$P(PSBREC(PSBCNT),U,4),(PSBREC(0)="I"),((PSBDD=53.796)!(PSBDD=53.797)) S $P(PSBREC(PSBCNT),U,4)=$$GET1^DIQ(PSBDD,PSBIENS,.02) ;set units administered, PSB*3*99
...D VAL^PSBML(PSBDD,PSBIENS,.01,"`"_$P(PSBREC(PSBCNT),U,2))
...D:PSBDD=53.795 VAL^PSBML(PSBDD,PSBIENS,.02,$P(PSBREC(PSBCNT),U,3))
...I (PSBDD=53.796!(PSBDD=53.797))&($P(PSBREC(PSBCNT),U,4)) D VAL^PSBML(PSBDD,PSBIENS,.02,$P(PSBREC(PSBCNT),U,4)) ;Store units in Units ordered field, PSB*3*72
...D:PSBDD=53.795 VAL^PSBML(PSBDD,PSBIENS,.03,$S(PSBREC(0)="G"!(PSBREC(0)="RM"):$P(PSBREC(PSBCNT),U,4),1:0)),VAL^PSBML(PSBDD,PSBIENS,.04,$P(PSBREC(PSBCNT),U,5))
...I PSBDD=53.796!(PSBDD=53.797),(PSBREC(0)="G"!(PSBREC(0)="I")) D VAL^PSBML(PSBDD,PSBIENS,.03,$P(PSBREC(PSBCNT),U,4)) ;set units administered, PSB*3*99
I ($G(PSBREC(PSBRECNO))']""),(PSBREC(0)="N"),($$GET1^DIQ(53.79,PSBIEN,.09,"I")="G") D
.S PSBX=0 F S PSBX=$O(^PSB(53.79,+PSBIEN,.5,PSBX)) Q:'+PSBX D VAL^PSBML(53.795,(PSBX_","_PSBIEN),.03,0)
;end DD validate/load logic
;
;Witness logic give & undo? *70
; give
I PSBWITHR>1,(PSBREC(0)="G"!(PSBREC(0)="I")) D ;Store new Witness, PSB*3.0*99
.D:PSBWITN VAL^PSBML(53.79,PSBIEN,.28,PSBNOW) ;Witness dt/time
.D:PSBWITN VAL^PSBML(53.79,PSBIEN,.29,"`"_PSBWITN) ;Witness duz
.D:PSBWITCM]"" VAL^PSBML(53.79,PSBIEN,.31,PSBWITCM) ;Witness comment
.D VAL^PSBML(53.79,PSBIEN,.32,PSBWITHR) ;Witness HR ord code
.D VAL^PSBML(53.79,PSBIEN,.33,PSBWITFL) ;Witnessed? flag
;
; undo give
I PSBWITHR>1,PSBREC(0)="N" D ;Undo Give of Witness fields *70
.N WTDT,WTNS,WTCM,WTHR,WTFL ;only delete if currently has data
.S WTDT=$$GET1^DIQ(53.79,+PSBIEN,.28,"I")
.S WTNS=$$GET1^DIQ(53.79,+PSBIEN,.29,"I")
.S WTCM=$$GET1^DIQ(53.79,+PSBIEN,.31,"I")
.S WTHR=$$GET1^DIQ(53.79,+PSBIEN,.32,"I")
.S WTFL=$$GET1^DIQ(53.79,+PSBIEN,.33,"I")
.D:WTDT VAL^PSBML(53.79,PSBIEN,.28,"@")
.D:WTNS VAL^PSBML(53.79,PSBIEN,.29,"@")
.D:WTCM]"" VAL^PSBML(53.79,PSBIEN,.31,"@")
.D:WTHR>1 VAL^PSBML(53.79,PSBIEN,.32,"@")
.D:WTFL]"" VAL^PSBML(53.79,PSBIEN,.33,"@")
;
;file 53.7 logic
D FILEIT^PSBML
;
;filing success and update PSJ filer logic
I $P($G(RESULTS(1)),U,1)=1 D
.S PSBUID=$P(^PSB(53.79,+PSBIEN,0),U,10) I PSBUID]"",PSBUID'["WS" D
..S PSBTS=PSBREC(0)
..S PSBON=$P(^PSB(53.79,+PSBIEN,.1),U,1)
..S PSBDFN=$P(^PSB(53.79,+PSBIEN,0),U,1)
..I PSBREC(0)="N" S PSBTS="" D
...M PSBAR=^PSB(53.79,+PSBIEN,.9)
...S (PSBDN,X)="" F S X=$O(PSBAR(X),-1) Q:X=0!(PSBDN=1) D
....I PSBAR(X,0)["ACTION STATUS",PSBAR(X,0)["deleted",PSBAR(X,0)'["GIVEN" D
.....S PSBTS=$P($P(PSBAR(X,0),"'",2),"'",1)
.....S PSBTS=$S(PSBTS="HELD":"H",PSBTS="REFUSED":"R",PSBTS="REMOVED":"RM",PSBTS="MISSING":"M",1:""),PSBDN=1
...D VAL^PSBML(53.79,PSBIEN,.26,"") D CLEAN^DILF,UPDATE^DIE("","PSBFDA","PSBIEN","PSBMSG")
..D EN^PSJBCMA3(PSBDFN,+PSBON,PSBUID,PSBTS,PSBNOW)
I ($$GET1^DIQ(53.79,+PSBIEN,.12,"I")="O")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="N") S PSBDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I") D ENR^PSJBCMA4(PSBDFN,$$GET1^DIQ(53.79,+PSBIEN,.11))
I ($$GET1^DIQ(53.79,+PSBIEN,.12,"I")="O")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G") S PSBDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I") D ENE^PSJBCMA4(PSBDFN,$$GET1^DIQ(53.79,+PSBIEN,.11))
;FIX FOR ONE-TIME WITH PRN ORDER PSB*3*124
N CPSP,CPS55,CPSDFN,CPSCH
I PSBXORN["U" D
.S CPSP=0
.S CPS55=$$GET1^DIQ(53.79,+PSBIEN,.11,"I")
.S CPSDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I")
.S CPSCH=$P($G(^PS(55,CPSDFN,5,+CPS55,2)),U,1)
.I $$ONE^PSJBCMA(CPSDFN,+CPS55,CPSCH)="O" S CPSP=1
.I (CPSP=1)&($$GET1^DIQ(53.79,+PSBIEN,.12,"I")="P")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="N") D
..S PSBDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I") D ENR^PSJBCMA4(PSBDFN,$$GET1^DIQ(53.79,+PSBIEN,.11))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBML2 13792 printed Apr 09, 2024@20:46:22 Page 2
PSBML2 ;BIRMINGHAM/TEJ-BCMA UTILITY TO EDIT THE PSB MED LOG ;03/06/16 3:06pm
+1 ;;3.0;BAR CODE MED ADMIN;**3,18,22,23,13,45,42,70,72,83,99,121,124,130**;Mar 2004;Build 1
+2 ;Per VA Directive 6402, this routine should not be modified
+3 ; Reference/IA
+4 ; EN^PSJBCMA3/3320
+5 ; ENE^PSJBCMA4/3416
+6 ; ENR^PSJBCMA4/3416
+7 ;
+8 ;*70 - update Witness if present and Giving now as an updated, could
+9 ; mean undo given or a hold/refused was done first.
+10 ;*83 - store MRR code to DD multiple .06 field, to update AMRR xref
+11 ;
EDIT ;
+1 KILL RESULTS
SET PSBEDIEN=PSBIEN_","
SET RESULTS(0)=0
+2 IF $GET(PSBREC(7))']""
SET RESULTS(0)=1
SET RESULTS(1)="-1^Data NOT filed - Comment is required"
QUIT
+3 Begin DoDot:1
+4 SET PSBEDTFL=1
SET PSBMODS=0
SET PSBREC(1)=""
+5 if PSBREC(4)]""
DO VAL^PSBML(53.79,PSBEDIEN,.06,PSBREC(4))
+6 IF (PSBREC(0)="N")
Begin DoDot:2
+7 IF ($$GET1^DIQ(53.79,PSBEDIEN,.11)["V")
FOR PSBX=1:1:6
SET PSBREC(PSBX)=""
End DoDot:2
+8 IF ("NHR"[PSBREC(0))
IF $DATA(^PSB(53.79,+PSBEDIEN,.2))
Begin DoDot:2
+9 ; Audit PRN
+10 if $PIECE(^PSB(53.79,+PSBEDIEN,.2),U,2)]""
DO AUDIT^PSBUTL(+PSBEDIEN,53.79,.22,$PIECE(^PSB(53.79,+PSBEDIEN,.2),U,2),"K")
+11 IF ($PIECE(^PSB(53.79,+PSBEDIEN,0),U,9)="G")!($PIECE(^PSB(53.79,+PSBEDIEN,0),U,9)="I")
Begin DoDot:3
+12 IF $DATA(^PSB(53.79,"APRN",$PIECE(^PSB(53.79,+PSBEDIEN,0),U,1),$PIECE(^PSB(53.79,+PSBEDIEN,0),U,6),+PSBEDIEN))
Begin DoDot:4
+13 KILL ^PSB(53.79,"APRN",$PIECE(^PSB(53.79,+PSBEDIEN,0),U,1),$PIECE(^PSB(53.79,+PSBEDIEN,0),U,6),+PSBEDIEN)
KILL ^PSB(53.79,+PSBEDIEN,.2)
End DoDot:4
End DoDot:3
End DoDot:2
+14 IF ("NHR"'[PSBREC(0))
if $GET(PSBREC(5))]""
DO VAL^PSBML(53.79,PSBEDIEN,.21,$GET(PSBREC(5)))
if $GET(PSBREC(6))]""
DO VAL^PSBML(53.79,PSBEDIEN,.22,$GET(PSBREC(6)))
+15 IF +$GET(RESULTS(0))<0
SET RESULTS(1)="-1^Data NOT filed - "_$PIECE(RESULTS(0),U,2)
SET RESULTS(0)=1
QUIT
+16 if $DATA(^PSB(53.79,+PSBEDIEN,.2))
DO VAL^PSBML(53.79,PSBEDIEN,.21,$GET(PSBREC(5)))
DO VAL^PSBML(53.79,PSBEDIEN,.22,$GET(PSBREC(6)))
+17 DO VAL^PSBML(53.793,"+2,"_PSBIEN,.01,PSBREC(7))
+18 DO VAL^PSBML(53.793,"+2,"_PSBIEN,.02,"`"_DUZ)
+19 DO VAL^PSBML(53.793,"+2,"_PSBIEN,.03,PSBNOW)
End DoDot:1
+20 if +$GET(RESULTS(1))<0
QUIT
+21 SET PSBMODS=$$CHANGE^PSBML3(.PSBREC,PSBEDIEN)
+22 if PSBMODS
DO UPDATED
+23 if ('$GET(PSBERR))&('$GET(PSBMODS))
DO FILEIT^PSBML
+24 ; Audit DD
+25 IF $DATA(PSBORDMD)
SET (PSBXY,PSBXZ)=""
Begin DoDot:1
+26 FOR
SET PSBXY=$ORDER(PSBORDMD(PSBXY))
if PSBXY=""
QUIT
SET PSBFDAX=$SELECT(PSBXY=.6:53.796,PSBXY=.7:53.797,1:53.795)
FOR
SET PSBXZ=$ORDER(PSBORDMD(PSBXY,PSBXZ))
if PSBXZ=""
QUIT
Begin DoDot:2
+27 SET PSBXACT=""
SET PSBXACT=$GET(PSBORDMD(PSBXY,PSBXZ,0))
+28 if PSBXACT["ADD"
DO AUDIT^PSBUTL(+PSBEDIEN,PSBFDAX,.01,PSBXZ,"S")
if PSBXACT["DELETE"
DO AUDIT^PSBUTL(+PSBEDIEN,PSBFDAX,.01,PSBXZ,"K")
End DoDot:2
End DoDot:1
+29 ;
+30 KILL PSBORDMD,PSBCHNG,PSBDDX,PSBEDTFL,PSBEDIEN,PSBFILED
+31 QUIT
+32 ;
UPDATED ;
+1 NEW PSBADD
+2 SET PSBIEN=PSBIEN_","
SET PSBXPTCH=0
+3 SET PSBRECNO=$SELECT(PSBEDTFL:8,1:4)
+4 IF "^G^N^H^R^RM^S^C^I^M^"[(U_PSBREC(0)_U)
Begin DoDot:1
+5 if ('PSBEDTFL)
DO VAL^PSBML(53.79,PSBIEN,.06,PSBNOW)
+6 if $DATA(PSBREC(4,0))
DO VAL^PSBML(53.79,PSBIEN,.06,PSBREC(4))
+7 DO VAL^PSBML(53.79,PSBIEN,.07,"`"_DUZ)
+8 if ('PSBEDTFL)!($GET(PSBREC(0,0)))
DO VAL^PSBML(53.79,PSBIEN,.09,PSBREC(0))
+9 IF $GET(PSBREC(3))]""
DO VAL^PSBML(53.79,PSBIEN,.26,PSBREC(3))
End DoDot:1
+10 IF $DATA(PSBREC(PSBRECNO))
if ($GET(PSBREC(0))="G")&($PIECE(PSBREC(PSBRECNO),U,5)["PATCH")
Begin DoDot:1
+11 if $$GET1^DIQ(53.79,PSBIEN,.09,"I")=""
QUIT
+12 SET PSBXDFN=$$GET1^DIQ(53.79,PSBIEN,.01,"I")
+13 SET PSBXORN=$$GET1^DIQ(53.79,+PSBIEN,.11,"I")
+14 SET PSBXDT=""
FOR
SET PSBXDT=$ORDER(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT))
if PSBXDT=""
QUIT
Begin DoDot:2
+15 SET PSBYZ=""
FOR
SET PSBYZ=$ORDER(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT,PSBYZ))
if 'PSBYZ
QUIT
IF ($$GET1^DIQ(53.79,PSBYZ,.09,"I")="G")
IF (PSBYZ'=+PSBIEN)
SET RESULTS(0)=1
SET RESULTS(1)="-1^Previous Patch has not been removed. Administration canceled."
QUIT
End DoDot:2
if +$GET(RESULTS(1))<0
QUIT
End DoDot:1
if +$GET(RESULTS(1))<0
QUIT
+16 if '$DATA(PSBXDFN)
SET PSBXDFN=$$GET1^DIQ(53.79,PSBIEN,.01,"I")
SET PSBXORN=$$GET1^DIQ(53.79,+PSBIEN,.11,"I")
+17 IF $GET(PSBREC(3))']""
IF $GET(PSBREC(0))="G"
IF $PIECE($GET(PSBREC(4)),U)'="DD"
IF $PIECE($GET(PSBREC(8)),U)'="DD"
SET PSBUID=$$GETWSID^PSBVDLU2(+PSBXDFN,+PSBXORN)
DO VAL^PSBML(53.79,PSBIEN,.26,PSBUID)
+18 ;
+19 if $GET(PSBREC(0))="N"
Begin DoDot:1
+20 IF (PSBREC(0)="N")
IF ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G")
SET PSBREC(1)="Undo Given: "_$GET(PSBREC(1))
+21 IF ((PSBREC(0)="N")!(PSBREC(0)="G"))
IF ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM")
SET PSBREC(1)="Undo Remove: "_$GET(PSBREC(1))
+22 ; Undo PRN
+23 IF $DATA(^PSB(53.79,+PSBIEN,.2))
Begin DoDot:2
+24 ;Use BCMA Edit function to delete PRN Reason Field
IF $PIECE(^PSB(53.79,+PSBIEN,0),U,9)="G"!($PIECE(^PSB(53.79,+PSBIEN,0),U,9)="I")
DO VAL^PSBML(53.79,PSBIEN,.21,"@")
Begin DoDot:3
+25 NEW DIK,DA
+26 ;Use BCMA Edit function to delete PRN Effectiveness fields
IF $$GET1^DIQ(53.79,PSBIEN_",",.22)]""
DO VAL^PSBML(53.79,PSBIEN,.22,"@")
DO VAL^PSBML(53.79,PSBIEN,.23,"@")
DO VAL^PSBML(53.79,PSBIEN,.24,"@")
DO VAL^PSBML(53.79,PSBIEN,.25,"@")
+27 ;Use FM to properly delete order status and clean up "APRN" cross reference,PSB*3*72
SET DIK(1)=".12"
SET DA=+PSBIEN
SET DIK="^PSB(53.79,"_DA_","
DO EN2^DIK
End DoDot:3
+28 ;Use BCMA Edit function to delete PRN Reason Flag field, PSB*3*72
if $$GET1^DIQ(53.79,PSBIEN_",",.27)=1
DO VAL^PSBML(53.79,PSBIEN,.27,"@")
End DoDot:2
End DoDot:1
+29 if $GET(PSBREC(1))]""
Begin DoDot:1
+30 if PSBREC(0)="H"
SET PSBREC(1)="Held: "_PSBREC(1)
+31 if PSBREC(0)="R"
SET PSBREC(1)="Refused: "_PSBREC(1)
+32 if PSBREC(0)="RM"
SET PSBREC(1)="Removed: "_PSBREC(1)
+33 IF $DATA(PSBFDA(53.793,"+2,"_PSBIEN,.01))
SET PSBREC(1)=PSBREC(1)_(PSBFDA(53.793,"+2,"_PSBIEN,.01))
+34 DO VAL^PSBML(53.793,"+2,"_PSBIEN,.01,PSBREC(1))
DO VAL^PSBML(53.793,"+2,"_PSBIEN,.02,"`"_DUZ)
DO VAL^PSBML(53.793,"+2,"_PSBIEN,.03,PSBNOW)
End DoDot:1
+35 SET PSBXDFN=$$GET1^DIQ(53.79,PSBIEN,.01,"I")
+36 IF ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM")
IF ((PSBREC(0)="N")!(PSBREC(0)="G"))
Begin DoDot:1
+37 IF '(($DATA(^XUSEC("PSB MANAGER",DUZ)))!($$GET1^DIQ(53.79,+PSBIEN,.07,"I")=DUZ))
SET RESULTS(0)=1
SET RESULTS(1)="-1^Verify PSB MANAGER allocation"
QUIT
+38 SET PSBXPTCH=1
SET PSBYY=""
SET PSBGIVEN=0
FOR
SET PSBYY=$ORDER(^PSB(53.79,+PSBIEN,.9,PSBYY),-1)
if 'PSBYY
QUIT
if (+$GET(RESULTS(0))<0)
QUIT
if PSBGIVEN
QUIT
SET PSBXDAT=$GET(^(PSBYY,0))
Begin DoDot:2
+39 ;PSB*3*45 Should be checking if action status changed to GIVEN
+40 IF $PIECE(PSBXDAT,"^",4)["GIVEN"
Begin DoDot:3
+41 SET PSBXDATE=$PIECE(^PSB(53.79,+PSBIEN,.9,PSBYY,0),U)
+42 SET PSBXORN=$$GET1^DIQ(53.79,+PSBIEN,.11,"I")
+43 SET PSBYX=(PSBYY-2)
IF (PSBYX)>0
IF ^PSB(53.79,+PSBIEN,.9,PSBYX,0)["ACTION DATE/TIME '"
SET PSBXDATE=$PIECE(^PSB(53.79,+PSBIEN,.9,PSBYX,0),"'",2)
SET X=$PIECE(PSBXDATE,"@")
SET %DT=""
DO ^%DT
SET PSBXDATE=Y_"."_$TRANSLATE($PIECE(PSBXDATE,"@",2),":")
+44 SET PSBXDT=""
FOR
SET PSBXDT=$ORDER(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT))
if PSBXDT=""
QUIT
Begin DoDot:4
+45 SET PSBYZ=""
FOR
SET PSBYZ=$ORDER(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT,PSBYZ))
if 'PSBYZ
QUIT
IF ($$GET1^DIQ(53.79,PSBYZ,.09,"I")="G")
IF (PSBYZ'=+PSBIEN)
SET RESULTS(0)=1
SET RESULTS(1)="-1^Cannot UNDO! Order has GIVEN patch"
QUIT
End DoDot:4
if +$GET(RESULTS(1))<0
QUIT
+46 IF '(+$GET(RESULTS(1))<0)
Begin DoDot:4
+47 ;PSB*3*45 Added PSBLSTG for the last user who gave the patch. this will be logged in order to undo multiple removed.
+48 SET PSBLSTG=$PIECE(PSBXDAT,"^",2)
SET I=""
FOR
SET I=$ORDER(^PSB(53.79,+PSBIEN,.9,I),-1)
if 'I
QUIT
IF $PIECE(^PSB(53.79,+PSBIEN,.9,I,0),"^",4)["GIVEN"
Begin DoDot:5
+49 SET PSBLSTG=$SELECT($PIECE($GET(PSBXDAT),"^",5):$PIECE(PSBXDAT,"^",5),1:$PIECE(PSBXDAT,"^",2))
End DoDot:5
QUIT
+50 DO VAL^PSBML(53.79,PSBIEN,.06,PSBXDATE)
DO VAL^PSBML(53.79,PSBIEN,.07,"`"_PSBLSTG)
DO VAL^PSBML(53.79,PSBIEN,.09,"G")
KILL PSBLSTG
End DoDot:4
SET PSBGIVEN=1
End DoDot:3
+51 if ('(+$GET(RESULTS(1))<0))&('PSBGIVEN)&($GET(PSBXPTCH))&(PSBYY'>1)
Begin DoDot:3
+52 SET PSBXDATE=$PIECE(^PSB(53.79,+PSBIEN,.9,PSBYY,0),"'",2)
SET X=$PIECE(PSBXDATE,"@")
SET %DT=""
DO ^%DT
SET PSBXDATE=Y_"."_$TRANSLATE($PIECE(PSBXDATE,"@",2),":")
+53 DO VAL^PSBML(53.79,PSBIEN,.06,PSBXDATE)
DO VAL^PSBML(53.79,PSBIEN,.07,"`"_$$GET1^DIQ(53.79,+PSBIEN,.07,"I"))
DO VAL^PSBML(53.79,PSBIEN,.09,"G")
SET PSBGIVEN=1
End DoDot:3
End DoDot:2
End DoDot:1
+54 if (+$GET(RESULTS(1))<0)
QUIT
+55 IF PSBEDTFL
IF $GET(PSBGIVEN)
IF PSBXPTCH
SET PSBREC(0)="G"
SET PSBUNTSG=$PIECE(PSBREC(8),U,4)
DO VAL^PSBML(53.795,(1_","_PSBIEN),.03,$SELECT(PSBUNTSG'=0:PSBUNTSG,1:1))
KILL PSBXPTCH
+56 ;Set or Del Derm/Inj site fields *83
+57 ;Del site, Undo Give
IF PSBREC(0)="N"
IF PSBREC(1)["Undo Given"
Begin DoDot:1
+58 DO VAL^PSBML(53.79,PSBIEN,.16,"@")
+59 DO VAL^PSBML(53.79,PSBIEN,.18,"@")
End DoDot:1
+60 ;Set site
IF PSBREC(0)="G"
IF $GET(PSBREC(2))]""
Begin DoDot:1
+61 NEW SITETXT,SITECD
+62 SET SITETXT=$PIECE(PSBREC(2),"|",1)
SET SITECD=$PIECE(PSBREC(2),"|",2)
+63 IF SITECD="D"
Begin DoDot:2
+64 ;Dermal site
DO VAL^PSBML(53.79,PSBIEN,.18,SITETXT)
End DoDot:2
+65 IF '$TEST
Begin DoDot:2
+66 ;Inject site
DO VAL^PSBML(53.79,PSBIEN,.16,SITETXT)
End DoDot:2
+67 ;
End DoDot:1
+68 SET PSBOLDUZ=$PIECE(^PSB(53.79,+PSBIEN,0),U,7)
SET PSBOLSTS=$PIECE(^PSB(53.79,+PSBIEN,0),U,9)
+69 ;
+70 ;DD/SOL/ADD validate/load array logic begins
+71 IF $GET(PSBREC(PSBRECNO))]""
Begin DoDot:1
+72 ; Only if gvn or infus
IF PSBREC(0)="G"!(PSBREC(0)="I")!(PSBREC(0)="H")!(PSBREC(0)="R")!(PSBREC(0)="M")
Begin DoDot:2
+73 if (PSBEDTFL)&('$GET(PSBCHNG))
QUIT
+74 FOR PSBCNT=PSBRECNO:1
if '$DATA(PSBREC(PSBCNT))
QUIT
Begin DoDot:3
+75 SET Y=$PIECE(PSBREC(PSBCNT),U)
+76 SET PSBDD=$SELECT(Y="DD":53.795,Y="ADD":53.796,Y="SOL":53.797,1:0)
+77 if 'PSBDD
QUIT
+78 IF $GET(PSBCHNG)
Begin DoDot:4
+79 IF $DATA(PSBFIND(PSBCNT))
SET PSBIENS=$QSUBSCRIPT($QUERY(PSBFIND(PSBCNT)),2)_","_PSBIEN
+80 IF '$DATA(PSBFIND(PSBCNT))
SET PSBIENS="+1,"_PSBIEN
+81 DO VAL^PSBML(PSBDD,PSBIENS,.01,"`"_$PIECE(PSBREC(PSBCNT),U,2))
+82 if PSBDD=53.795
DO VAL^PSBML(PSBDD,PSBIENS,.02,$PIECE(PSBREC(PSBCNT),U,3))
+83 ;Store Units administered when infused, PSB*3*99
IF '$PIECE(PSBREC(PSBCNT),U,4)
IF PSBREC(0)="I"
IF ((PSBDD=53.796)!(PSBDD=53.797))
SET $PIECE(PSBREC(PSBCNT),U,4)=$$GET1^DIQ(PSBDD,PSBIENS_",",.02)
+84 ;Store units in Units ordered field, PSB*3*72
IF (PSBDD=53.796!(PSBDD=53.797))&($PIECE(PSBREC(PSBCNT),U,4))
DO VAL^PSBML(PSBDD,PSBIENS,.02,$PIECE(PSBREC(PSBCNT),U,4))
+85 ;only store units given when infusing or given, PSB*3*72
if PSBREC(0)="G"!(PSBREC(0)="I")
DO VAL^PSBML(PSBDD,PSBIENS,.03,$PIECE(PSBREC(PSBCNT),U,4))
+86 if PSBDD=53.795
DO VAL^PSBML(PSBDD,PSBIENS,.04,$PIECE(PSBREC(PSBCNT),U,5))
+87 ;HR *70
DO VAL^PSBML(PSBDD,PSBIENS,.05,$PIECE(PSBREC(PSBCNT),U,6))
+88 ;MRR *83
if PSBDD=53.795
DO VAL^PSBML(PSBDD,PSBIENS,.06,$PIECE(PSBREC(PSBCNT),U,7))
End DoDot:4
End DoDot:3
End DoDot:2
+89 IF ('PSBEDTFL)!((PSBREC(0)'="G")&($$GET1^DIQ(53.79,PSBIEN,.09,"I")="G"))
Begin DoDot:2
+90 SET (PSBDCNT,PSBACNT,PSBSCNT)=0
SET PSBADD=3
FOR PSBCNT=PSBRECNO:1
if '$DATA(PSBREC(PSBCNT))
QUIT
Begin DoDot:3
+91 SET Y=$PIECE(PSBREC(PSBCNT),U)
+92 SET PSBDD=$SELECT(Y="DD":53.795,Y="ADD":53.796,Y="SOL":53.797,1:0)
+93 if 'PSBDD
QUIT
+94 SET @("PSB"_$EXTRACT(Y)_"CNT")=@("PSB"_$EXTRACT(Y)_"CNT")+1
+95 SET PSBIENS=(@("PSB"_$EXTRACT(Y)_"CNT"))_","_PSBIEN
+96 IF '$$GET1^DIQ(PSBDD,PSBIENS,.01,"I")
SET PSBIENS="+"_PSBADD_","_PSBIEN
SET PSBADD=PSBADD+1
+97 ;Clear old units, PSB*3*99
+98 IF Y="DD"
IF (PSBREC(0)="G"!(PSBREC(0)="RM"))
Begin DoDot:4
+99 SET PSBMLT=1
FOR
SET PSBMLT=$ORDER(^PSB(53.79,+PSBIEN,.5,PSBMLT))
if 'PSBMLT
QUIT
Begin DoDot:5
+100 IF $GET(PSBFDA(PSBDD,PSBMLT_","_PSBIEN,.01))=""
DO VAL^PSBML(PSBDD,PSBMLT_","_PSBIEN,.01,"@")
End DoDot:5
End DoDot:4
+101 ;set units administered, PSB*3*99
IF '$PIECE(PSBREC(PSBCNT),U,4)
IF (PSBREC(0)="I")
IF ((PSBDD=53.796)!(PSBDD=53.797))
SET $PIECE(PSBREC(PSBCNT),U,4)=$$GET1^DIQ(PSBDD,PSBIENS,.02)
+102 DO VAL^PSBML(PSBDD,PSBIENS,.01,"`"_$PIECE(PSBREC(PSBCNT),U,2))
+103 if PSBDD=53.795
DO VAL^PSBML(PSBDD,PSBIENS,.02,$PIECE(PSBREC(PSBCNT),U,3))
+104 ;Store units in Units ordered field, PSB*3*72
IF (PSBDD=53.796!(PSBDD=53.797))&($PIECE(PSBREC(PSBCNT),U,4))
DO VAL^PSBML(PSBDD,PSBIENS,.02,$PIECE(PSBREC(PSBCNT),U,4))
+105 if PSBDD=53.795
DO VAL^PSBML(PSBDD,PSBIENS,.03,$SELECT(PSBREC(0)="G"!(PSBREC(0)="RM"):$PIECE(PSBREC(PSBCNT),U,4),1:0))
DO VAL^PSBML(PSBDD,PSBIENS,.04,$PIECE(PSBREC(PSBCNT),U,5))
+106 ;set units administered, PSB*3*99
IF PSBDD=53.796!(PSBDD=53.797)
IF (PSBREC(0)="G"!(PSBREC(0)="I"))
DO VAL^PSBML(PSBDD,PSBIENS,.03,$PIECE(PSBREC(PSBCNT),U,4))
End DoDot:3
End DoDot:2
End DoDot:1
+107 IF ($GET(PSBREC(PSBRECNO))']"")
IF (PSBREC(0)="N")
IF ($$GET1^DIQ(53.79,PSBIEN,.09,"I")="G")
Begin DoDot:1
+108 SET PSBX=0
FOR
SET PSBX=$ORDER(^PSB(53.79,+PSBIEN,.5,PSBX))
if '+PSBX
QUIT
DO VAL^PSBML(53.795,(PSBX_","_PSBIEN),.03,0)
End DoDot:1
+109 ;end DD validate/load logic
+110 ;
+111 ;Witness logic give & undo? *70
+112 ; give
+113 ;Store new Witness, PSB*3.0*99
IF PSBWITHR>1
IF (PSBREC(0)="G"!(PSBREC(0)="I"))
Begin DoDot:1
+114 ;Witness dt/time
if PSBWITN
DO VAL^PSBML(53.79,PSBIEN,.28,PSBNOW)
+115 ;Witness duz
if PSBWITN
DO VAL^PSBML(53.79,PSBIEN,.29,"`"_PSBWITN)
+116 ;Witness comment
if PSBWITCM]""
DO VAL^PSBML(53.79,PSBIEN,.31,PSBWITCM)
+117 ;Witness HR ord code
DO VAL^PSBML(53.79,PSBIEN,.32,PSBWITHR)
+118 ;Witnessed? flag
DO VAL^PSBML(53.79,PSBIEN,.33,PSBWITFL)
End DoDot:1
+119 ;
+120 ; undo give
+121 ;Undo Give of Witness fields *70
IF PSBWITHR>1
IF PSBREC(0)="N"
Begin DoDot:1
+122 ;only delete if currently has data
NEW WTDT,WTNS,WTCM,WTHR,WTFL
+123 SET WTDT=$$GET1^DIQ(53.79,+PSBIEN,.28,"I")
+124 SET WTNS=$$GET1^DIQ(53.79,+PSBIEN,.29,"I")
+125 SET WTCM=$$GET1^DIQ(53.79,+PSBIEN,.31,"I")
+126 SET WTHR=$$GET1^DIQ(53.79,+PSBIEN,.32,"I")
+127 SET WTFL=$$GET1^DIQ(53.79,+PSBIEN,.33,"I")
+128 if WTDT
DO VAL^PSBML(53.79,PSBIEN,.28,"@")
+129 if WTNS
DO VAL^PSBML(53.79,PSBIEN,.29,"@")
+130 if WTCM]""
DO VAL^PSBML(53.79,PSBIEN,.31,"@")
+131 if WTHR>1
DO VAL^PSBML(53.79,PSBIEN,.32,"@")
+132 if WTFL]""
DO VAL^PSBML(53.79,PSBIEN,.33,"@")
End DoDot:1
+133 ;
+134 ;file 53.7 logic
+135 DO FILEIT^PSBML
+136 ;
+137 ;filing success and update PSJ filer logic
+138 IF $PIECE($GET(RESULTS(1)),U,1)=1
Begin DoDot:1
+139 SET PSBUID=$PIECE(^PSB(53.79,+PSBIEN,0),U,10)
IF PSBUID]""
IF PSBUID'["WS"
Begin DoDot:2
+140 SET PSBTS=PSBREC(0)
+141 SET PSBON=$PIECE(^PSB(53.79,+PSBIEN,.1),U,1)
+142 SET PSBDFN=$PIECE(^PSB(53.79,+PSBIEN,0),U,1)
+143 IF PSBREC(0)="N"
SET PSBTS=""
Begin DoDot:3
+144 MERGE PSBAR=^PSB(53.79,+PSBIEN,.9)
+145 SET (PSBDN,X)=""
FOR
SET X=$ORDER(PSBAR(X),-1)
if X=0!(PSBDN=1)
QUIT
Begin DoDot:4
+146 IF PSBAR(X,0)["ACTION STATUS"
IF PSBAR(X,0)["deleted"
IF PSBAR(X,0)'["GIVEN"
Begin DoDot:5
+147 SET PSBTS=$PIECE($PIECE(PSBAR(X,0),"'",2),"'",1)
+148 SET PSBTS=$SELECT(PSBTS="HELD":"H",PSBTS="REFUSED":"R",PSBTS="REMOVED":"RM",PSBTS="MISSING":"M",1:"")
SET PSBDN=1
End DoDot:5
End DoDot:4
+149 DO VAL^PSBML(53.79,PSBIEN,.26,"")
DO CLEAN^DILF
DO UPDATE^DIE("","PSBFDA","PSBIEN","PSBMSG")
End DoDot:3
+150 DO EN^PSJBCMA3(PSBDFN,+PSBON,PSBUID,PSBTS,PSBNOW)
End DoDot:2
End DoDot:1
+151 IF ($$GET1^DIQ(53.79,+PSBIEN,.12,"I")="O")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="N")
SET PSBDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I")
DO ENR^PSJBCMA4(PSBDFN,$$GET1^DIQ(53.79,+PSBIEN,.11))
+152 IF ($$GET1^DIQ(53.79,+PSBIEN,.12,"I")="O")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G")
SET PSBDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I")
DO ENE^PSJBCMA4(PSBDFN,$$GET1^DIQ(53.79,+PSBIEN,.11))
+153 ;FIX FOR ONE-TIME WITH PRN ORDER PSB*3*124
+154 NEW CPSP,CPS55,CPSDFN,CPSCH
+155 IF PSBXORN["U"
Begin DoDot:1
+156 SET CPSP=0
+157 SET CPS55=$$GET1^DIQ(53.79,+PSBIEN,.11,"I")
+158 SET CPSDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I")
+159 SET CPSCH=$PIECE($GET(^PS(55,CPSDFN,5,+CPS55,2)),U,1)
+160 IF $$ONE^PSJBCMA(CPSDFN,+CPS55,CPSCH)="O"
SET CPSP=1
+161 IF (CPSP=1)&($$GET1^DIQ(53.79,+PSBIEN,.12,"I")="P")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="N")
Begin DoDot:2
+162 SET PSBDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I")
DO ENR^PSJBCMA4(PSBDFN,$$GET1^DIQ(53.79,+PSBIEN,.11))
End DoDot:2
End DoDot:1
+163 QUIT
