PSBML2 ;BIRMINGHAM/TEJ-BCMA UTILITY TO EDIT THE PSB MED LOG ;10/20/10 12:36pm
;;3.0;BAR CODE MED ADMIN;**3,18,22,23,13,45,42**;Mar 2004;Build 23
;Per VHA Directive 2004-038, this routine should not be modified.;
; Reference/IA
; EN^PSJBCMA3/3320
; ENE^PSJBCMA4/3416
; ENR^PSJBCMA4/3416
;
;
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
..D:$P(^PSB(53.79,+PSBIEN,.2),U,2)]"" AUDIT^PSBUTL(+PSBIEN,53.79,.22,$P(^PSB(53.79,+PSBIEN,.2),U,2),"K")
..I ($P(^PSB(53.79,+PSBIEN,0),U,9)="G")!($P(^PSB(53.79,+PSBIEN,0),U,9)="I") K ^PSB(53.79,"APRN",$P(^PSB(53.79,+PSBIEN,0),U,1),$P(^PSB(53.79,+PSBIEN,0),U,6),+PSBIEN),^PSB(53.79,+PSBIEN,.2)
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
I $G(PSBREC(2))]"" D VAL^PSBML(53.79,PSBIEN,.16,PSBREC(2))
S PSBOLDUZ=$P(^PSB(53.79,+PSBIEN,0),U,7),PSBOLSTS=$P(^PSB(53.79,+PSBIEN,0),U,9)
I $G(PSBREC(PSBRECNO))]"" D ; DD/SOL/ADD
.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 VAL^PSBML(PSBDD,PSBIENS,.02,$P(PSBREC(PSBCNT),U,3))
....D VAL^PSBML(PSBDD,PSBIENS,.03,$P(PSBREC(PSBCNT),U,4))
....D:Y="DD" VAL^PSBML(PSBDD,PSBIENS,.04,$P(PSBREC(PSBCNT),U,5))
.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
...D VAL^PSBML(PSBDD,PSBIENS,.01,"`"_$P(PSBREC(PSBCNT),U,2))
...D VAL^PSBML(PSBDD,PSBIENS,.02,$P(PSBREC(PSBCNT),U,3))
...D:Y="DD" 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" D VAL^PSBML(PSBDD,PSBIENS,.03,$P(PSBREC(PSBCNT),U,4))
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)
D FILEIT^PSBML
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))
I (PSBREC(0)="N")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="N") D NGRESET^PSBML3(.PSBREC,PSBIEN)
Q
;
PSBML2 ;BIRMINGHAM/TEJ-BCMA UTILITY TO EDIT THE PSB MED LOG ;10/20/10 12:36pm
+1 ;;3.0;BAR CODE MED ADMIN;**3,18,22,23,13,45,42**;Mar 2004;Build 23
+2 ;Per VHA Directive 2004-038, this routine should not be modified.;
+3 ; Reference/IA
+4 ; EN^PSJBCMA3/3320
+5 ; ENE^PSJBCMA4/3416
+6 ; ENR^PSJBCMA4/3416
+7 ;
+8 ;
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 IF $GET(PSBREC(0))="N"
Begin DoDot:1
+19 IF (PSBREC(0)="N")
IF ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G")
SET PSBREC(1)="Undo Given: "_$GET(PSBREC(1))
+20 IF ((PSBREC(0)="N")!(PSBREC(0)="G"))
IF ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM")
SET PSBREC(1)="Undo Remove: "_$GET(PSBREC(1))
+21 ; Undo PRN
+22 IF $DATA(^PSB(53.79,+PSBIEN,.2))
Begin DoDot:2
+23 IF $PIECE(^PSB(53.79,+PSBIEN,.2),U,2)]""
DO AUDIT^PSBUTL(+PSBIEN,53.79,.22,$PIECE(^PSB(53.79,+PSBIEN,.2),U,2),"K")
+24 IF ($PIECE(^PSB(53.79,+PSBIEN,0),U,9)="G")!($PIECE(^PSB(53.79,+PSBIEN,0),U,9)="I")
KILL ^PSB(53.79,"APRN",$PIECE(^PSB(53.79,+PSBIEN,0),U,1),$PIECE(^PSB(53.79,+PSBIEN,0),U,6),+PSBIEN),^PSB(53.79,+PSBIEN,.2)
End DoDot:2
End DoDot:1
+25 IF $GET(PSBREC(1))]""
Begin DoDot:1
+26 IF PSBREC(0)="H"
SET PSBREC(1)="Held: "_PSBREC(1)
+27 IF PSBREC(0)="R"
SET PSBREC(1)="Refused: "_PSBREC(1)
+28 IF PSBREC(0)="RM"
SET PSBREC(1)="Removed: "_PSBREC(1)
+29 IF $DATA(PSBFDA(53.793,"+2,"_PSBIEN,.01))
SET PSBREC(1)=PSBREC(1)_(PSBFDA(53.793,"+2,"_PSBIEN,.01))
+30 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
+31 SET PSBXDFN=$$GET1^DIQ(53.79,PSBIEN,.01,"I")
+32 IF ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM")
IF ((PSBREC(0)="N")!(PSBREC(0)="G"))
Begin DoDot:1
+33 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
+34 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
+35 ;PSB*3*45 Should be checking if action status changed to GIVEN
+36 IF $PIECE(PSBXDAT,"^",4)["GIVEN"
Begin DoDot:3
+37 SET PSBXDATE=$PIECE(^PSB(53.79,+PSBIEN,.9,PSBYY,0),U)
+38 SET PSBXORN=$$GET1^DIQ(53.79,+PSBIEN,.11,"I")
+39 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),":")
+40 SET PSBXDT=""
FOR
SET PSBXDT=$ORDER(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT))
IF PSBXDT=""
QUIT
Begin DoDot:4
+41 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
+42 IF '(+$GET(RESULTS(1))<0)
Begin DoDot:4
+43 ;PSB*3*45 Added PSBLSTG for the last user who gave the patch. this will be logged in order to undo multiple removed.
+44 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
+45 SET PSBLSTG=$SELECT($PIECE($GET(PSBXDAT),"^",5):$PIECE(PSBXDAT,"^",5),1:$PIECE(PSBXDAT,"^",2))
End DoDot:5
QUIT
+46 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
+47 IF ('(+$GET(RESULTS(1))<0))&('PSBGIVEN)&($GET(PSBXPTCH))&(PSBYY'>1)
Begin DoDot:3
+48 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),":")
+49 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
+50 IF (+$GET(RESULTS(1))<0)
QUIT
+51 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
+52 IF $GET(PSBREC(2))]""
DO VAL^PSBML(53.79,PSBIEN,.16,PSBREC(2))
+53 SET PSBOLDUZ=$PIECE(^PSB(53.79,+PSBIEN,0),U,7)
SET PSBOLSTS=$PIECE(^PSB(53.79,+PSBIEN,0),U,9)
+54 ; DD/SOL/ADD
IF $GET(PSBREC(PSBRECNO))]""
Begin DoDot:1
+55 ; Only if gvn or infus
IF PSBREC(0)="G"!(PSBREC(0)="I")!(PSBREC(0)="H")!(PSBREC(0)="R")!(PSBREC(0)="M")
Begin DoDot:2
+56 IF (PSBEDTFL)&('$GET(PSBCHNG))
QUIT
+57 FOR PSBCNT=PSBRECNO:1
IF '$DATA(PSBREC(PSBCNT))
QUIT
Begin DoDot:3
+58 SET Y=$PIECE(PSBREC(PSBCNT),U)
+59 SET PSBDD=$SELECT(Y="DD":53.795,Y="ADD":53.796,Y="SOL":53.797,1:0)
+60 IF 'PSBDD
QUIT
+61 IF $GET(PSBCHNG)
Begin DoDot:4
+62 IF $DATA(PSBFIND(PSBCNT))
SET PSBIENS=$QSUBSCRIPT($QUERY(PSBFIND(PSBCNT)),2)_","_PSBIEN
+63 IF '$DATA(PSBFIND(PSBCNT))
SET PSBIENS="+1,"_PSBIEN
+64 DO VAL^PSBML(PSBDD,PSBIENS,.01,"`"_$PIECE(PSBREC(PSBCNT),U,2))
+65 DO VAL^PSBML(PSBDD,PSBIENS,.02,$PIECE(PSBREC(PSBCNT),U,3))
+66 DO VAL^PSBML(PSBDD,PSBIENS,.03,$PIECE(PSBREC(PSBCNT),U,4))
+67 IF Y="DD"
DO VAL^PSBML(PSBDD,PSBIENS,.04,$PIECE(PSBREC(PSBCNT),U,5))
End DoDot:4
End DoDot:3
End DoDot:2
+68 IF ('PSBEDTFL)!((PSBREC(0)'="G")&($$GET1^DIQ(53.79,PSBIEN,.09,"I")="G"))
Begin DoDot:2
+69 SET (PSBDCNT,PSBACNT,PSBSCNT)=0
SET PSBADD=3
FOR PSBCNT=PSBRECNO:1
IF '$DATA(PSBREC(PSBCNT))
QUIT
Begin DoDot:3
+70 SET Y=$PIECE(PSBREC(PSBCNT),U)
+71 SET PSBDD=$SELECT(Y="DD":53.795,Y="ADD":53.796,Y="SOL":53.797,1:0)
+72 IF 'PSBDD
QUIT
+73 SET @("PSB"_$EXTRACT(Y)_"CNT")=@("PSB"_$EXTRACT(Y)_"CNT")+1
+74 SET PSBIENS=(@("PSB"_$EXTRACT(Y)_"CNT"))_","_PSBIEN
+75 IF '$$GET1^DIQ(PSBDD,PSBIENS,.01,"I")
SET PSBIENS="+"_PSBADD_","_PSBIEN
SET PSBADD=PSBADD+1
+76 DO VAL^PSBML(PSBDD,PSBIENS,.01,"`"_$PIECE(PSBREC(PSBCNT),U,2))
+77 DO VAL^PSBML(PSBDD,PSBIENS,.02,$PIECE(PSBREC(PSBCNT),U,3))
+78 IF Y="DD"
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))
+79 IF PSBDD=53.796!(PSBDD=53.797)
IF PSBREC(0)="G"
DO VAL^PSBML(PSBDD,PSBIENS,.03,$PIECE(PSBREC(PSBCNT),U,4))
End DoDot:3
End DoDot:2
End DoDot:1
+80 IF ($GET(PSBREC(PSBRECNO))']"")
IF (PSBREC(0)="N")
IF ($$GET1^DIQ(53.79,PSBIEN,.09,"I")="G")
Begin DoDot:1
+81 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
+82 DO FILEIT^PSBML
+83 IF $PIECE($GET(RESULTS(1)),U,1)=1
Begin DoDot:1
+84 SET PSBUID=$PIECE(^PSB(53.79,+PSBIEN,0),U,10)
IF PSBUID]""
IF PSBUID'["WS"
Begin DoDot:2
+85 SET PSBTS=PSBREC(0)
+86 SET PSBON=$PIECE(^PSB(53.79,+PSBIEN,.1),U,1)
+87 SET PSBDFN=$PIECE(^PSB(53.79,+PSBIEN,0),U,1)
+88 IF PSBREC(0)="N"
SET PSBTS=""
Begin DoDot:3
+89 MERGE PSBAR=^PSB(53.79,+PSBIEN,.9)
+90 SET (PSBDN,X)=""
FOR
SET X=$ORDER(PSBAR(X),-1)
IF X=0!(PSBDN=1)
QUIT
Begin DoDot:4
+91 IF PSBAR(X,0)["ACTION STATUS"
IF PSBAR(X,0)["deleted"
IF PSBAR(X,0)'["GIVEN"
Begin DoDot:5
+92 SET PSBTS=$PIECE($PIECE(PSBAR(X,0),"'",2),"'",1)
+93 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
+94 DO VAL^PSBML(53.79,PSBIEN,.26,"")
DO CLEAN^DILF
DO UPDATE^DIE("","PSBFDA","PSBIEN","PSBMSG")
End DoDot:3
+95 DO EN^PSJBCMA3(PSBDFN,+PSBON,PSBUID,PSBTS,PSBNOW)
End DoDot:2
End DoDot:1
+96 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))
+97 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))
+98 IF (PSBREC(0)="N")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="N")
DO NGRESET^PSBML3(.PSBREC,PSBIEN)
+99 QUIT
+100 ;
