PSBML2.m

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 ---PSBML2   13792     printed  Mar 13, 2025@20:44:48                                                                                                                                                                                                     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