PSBOMH1 ;BIRMINGHAM/EFC-MAH ;Sep 01, 2020@15:11:32
;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,38,45,51,50,57,67,64,72,83,97,112,116,120,82**;Mar 2004;Build 27
;Per VHA Directive 2004-038, this routine should not be modified.
;
; Reference/IA
; ^DILF/2054
; File 200/10060
;
;*83 - add Remove events per Give events when occurred.
;
EN ;
; Load administrations
N PSBDT,PSBADMDT,X,Y,I,S,PSBINIT,PSBNAME,PRELINE1,PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR,PSBLINE1,PSBLINE2,PSBRTXTW,PSBS,PSBTAR
S (PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR)="",PSBDT=PSBSTRT
;ERROR
F S PSBDT=$O(^PSB(53.79,"AADT",DFN,PSBDT)) Q:'PSBDT D
.F S PSBIEN=$O(^PSB(53.79,"AADT",DFN,PSBDT,PSBIEN)) Q:'PSBIEN Q:'$D(^PSB(53.79,PSBIEN)) I $P(^PSB(53.79,PSBIEN,0),U,9)]"" D ;Remove Lock as file is only read, PSB*3*64
..Q:'$P($G(^PSB(53.79,PSBIEN,0)),U,6) ; Bad IEN -no evnt dt
..Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N" ;NGiven
..S PSBADMDT=PSBDT I $P(^PSB(53.79,PSBIEN,0),U,9)="RM" S:(PSBDT>PSBSTOP) PSBADMDT=+$$FINDGIVE^PSBUTL(PSBIEN) I ((PSBADMDT<PSBSTRT)!(PSBADMDT>PSBSTOP))&(PSBDT>PSBSTOP) Q
..I $P(^PSB(53.79,PSBIEN,0),U,9)'="RM",PSBDT>PSBSTOP Q
..S PSBORD=$P($G(^PSB(53.79,PSBIEN,.1)),U,1)
..;PSB*3*45 Anyone on the audit log should be in the legend
..N TMPCT S TMPCT=0 F S TMPCT=$O(^PSB(53.79,PSBIEN,.9,TMPCT)) Q:'TMPCT D
...S PSBINIT=$$GET1^DIQ(53.799,TMPCT_","_PSBIEN,"USER:INITIAL"),PSBNAME=$$GET1^DIQ(53.799,TMPCT_","_PSBIEN_",","USER")
...S:PSBINIT="" PSBINIT=99
...S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
..; Continuous
..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="C"
...S X=PSBADMDT D H^%DTC S PSBWEEK=+$G(PSBAR(%H)) D CLEAN^PSBVT,PSJ1^PSBVT($P(^PSB(53.79,PSBIEN,0),U,1),$P(^PSB(53.79,PSBIEN,.1),U,1))
...I $P(^PSB(53.79,PSBIEN,0),U,6)'=PSBDT,'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH) D D CLEAN^PSBVT Q ;chck IV audit
....S PSBSIEN=PSBIEN
....I $P(^PSB(53.79,PSBIEN,0),"^",10)]"" D BAGDTL^PSBRPC2(.PSBAUD,$P(^PSB(53.79,PSBIEN,0),U,10),$P(^PSB(53.79,PSBIEN,.1),U,1))
....S PSBIEN=PSBSIEN K PSBSIEN
....S X=0 F S X=$O(PSBAUD(X)) Q:X="" I $P(PSBAUD(X),U,3)="" K PSBAUD(X)
....S X=0 F S X=$O(PSBAUD(X)) Q:X="" Q:$P(PSBAUD(X),U,1)=PSBDT
....I X="" K PSBAUD Q
....I '$D(PSBAUD(X)) K PSBAUD Q
....S PSBS=$P(PSBAUD(X),U,3)
....I PSBS="GIVEN",$P($G(PSBAUD(X-1)),U,3)="NOT GIVEN" Q
....I PSBS="NOT GIVEN" Q
....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NOACTION")
....D PSBSTIV^PSBOMH2
....S X=PSBDT_U_$P(PSBAUD(X),U,2)_U_PSBS_U_PSBIEN
....S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X ;PSB*3*67
....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
....D PSBOUT($P((X),"^",1),$P((X),"^",2))
....K PSBAUD
...S PSBINIT=$$GETINIT^PSBCSUTX(PSBIEN,"I") ;Get initials of who took action, PSB*3*72
...S PSBNAME=$$GETINIT^PSBCSUTX(PSBIEN,"N") ;Get name of who took action, PSB*3*72
...I PSBINIT="" S PSBINIT=99
...;get instrc info - audt log
...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
....D INSTR^PSBOMH
....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
...I PSBINIT[99 S PSBINIT=""
...I $P(^PSB(53.79,PSBIEN,0),U,9)="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6) D PSBCK1^PSBOMH2("A")
...I $P(^PSB(53.79,PSBIEN,0),U,9)'="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6) D PSBCK1^PSBOMH2("B")
...I PSBDT'=$P(^PSB(53.79,PSBIEN,0),U,6),$P(^PSB(53.79,PSBIEN,0),U,9)="RM" D
....D DDAUD
....S I="" F S I=$O(PSBTAR(I),-1) Q:I="" I $P(PSBTAR(I),U,1)=PSBDT D
.....S PSBS=$P(PSBTAR(I),U,3)
.....I PSBS="GIVEN",$P($G(PSBTAR(I-1)),U,3)="NOT GIVEN" Q ; canceled - not given
.....I PSBS="NOT GIVEN" Q
.....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NO ACTION")
.....D PSBCTAR^PSBOMH2
.....S X=$P(PSBTAR(I),U,1,2)_U_PSBS_U_PSBIEN
...Q:'+X ;Quit if invalid data is returned, PSB*3*67
...;
...; PSB*3.0*82 - find all previous statuses, not just Given for Removed
...N PSB9CNT,PSB9REC,PSBOLDST,X2REC,X2,X2CNT
...S PSB9CNT=0
...F S PSB9CNT=$O(^PSB(53.79,PSBIEN,.9,PSB9CNT)) Q:'PSB9CNT D
....S PSB9REC=$G(^PSB(53.79,PSBIEN,.9,PSB9CNT,0)) Q:PSB9REC']""
....Q:PSB9REC'["ACTION STATUS Set to"
....S PSBOLDST=$E($P(PSB9REC,U,4),1,3) S:PSBOLDST="REM" PSBOLDST="RM"
....S:PSBOLDST'="RM" PSBOLDST=$E(PSBOLDST,1)
....S X2REC=$P(PSB9REC,U,1)_U_$P($P(PSB9REC,U,3),"'",4)_U_PSBOLDST_U_PSBIEN
....S X2CNT=$O(X2(""),-1)+1,X2(X2CNT)=X2REC
...S X2CNT=$O(X2(""),-1) I X2CNT]"" K X2(X2CNT)
...S X2CNT="" F S X2CNT=$O(X2(X2CNT)) Q:X2CNT="" D
....S X2REC=X2(X2CNT)
....Q:'$D(^TMP("PSB",$J,PSBWEEK,"HDR",$P(X2REC,U)\1))
....S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,$P(X2REC,U)\1,""),-1)+1
....S ^TMP("PSB",$J,PSBWEEK,PSBORD,$P(X2REC,U)\1,Y)=X2REC
....S ^TMP("PSB",$J,PSBWEEK,PSBORD,$P(X2REC,U)\1,0)=Y
...S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X ;PSB*3*67
...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
...D PSBOUT($P((X),"^",1),$P((X),"^",2))
...Q
..;
..; 1-Time On Call or PRN
..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)'="C"
...I PSBDT'=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I") Q
...S PSBINIT=$$GETINIT^PSBCSUTX(PSBIEN,"I") ;Get initials of who took action, PSB*3*72
...S PSBNAME=$$GETINIT^PSBCSUTX(PSBIEN,"N") ;Get name of who took action, PSB*3*72
...I PSBINIT="" S PSBINIT=99
...N PSBXA,PSBM,PSBZ,PSBT,PSBFLG
...S (PSBXA,PSBM)=1,(PSBZ,PSBT,PSBFLG)=""
...I $$GET1^DIQ(53.79,PSBIEN_",",.09)="REMOVED" D
....F I=1:1 S PSBXA=$O(^PSB(53.79,PSBIEN,.9,PSBXA)) Q:PSBXA="" I PSBXA?1.3N S PSBZ=PSBZ+1,PSBT(PSBZ)=^PSB(53.79,PSBIEN,.9,PSBXA,0)
....F S=1:1 Q:PSBM<1 S PSBM=PSBZ-S I (PSBM>0) I (PSBT(PSBM)["GIVEN") S PSBFLG="1" S PRELINE1=$P(PSBT(PSBM),"'",2)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.04)_" "_$E($P(PSBT(PSBM),"'",4),1,3) Q
...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
....D INSTR^PSBOMH
....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
...I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D PSBOUT(PSBDT,PSBINIT)
...S PSBLINE1=$$GET1^DIQ(53.79,PSBIEN_",",.09)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.06)_" "_PSBINIT_" "_$$GET1^DIQ(53.79,PSBIEN_",",.21),PSBLINE2=""
...I PSBINIT[99 S PSBINIT=""
...D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="P"
....I $P($G(^PSB(53.79,PSBIEN,.2)),U,2)="" S PSBLINE2=" Results: <No PRN Results On File>"
....E D
.....S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:INITIAL")
.....S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:NAME")
.....I PSBINIT="" S PSBINIT=99
.....I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
......S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."),0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
......S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
.....I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
......D:$D(^PSB(53.79,PSBIEN,.9,0))
.......N PSBXA2,PSBFG,PSBEFFDT
.......S (PSBXA2,PSBFG)=0,PSBEFFDT=$P(^PSB(53.79,PSBIEN,.2),U,4) F S PSBXA2=$O(^PSB(53.79,PSBIEN,.9,PSBXA2)) Q:+PSBXA2'>0 D Q:PSBFG=1
........D:($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U)=PSBEFFDT)&($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)["Instruct")&($P(^PSB(53.79,PSBIEN,.2),U,3)=$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,2))
.........S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
.........S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="",PSBFG=1
.....S PSBLINE2=" Results: "_$$GET1^DIQ(53.79,PSBIEN_",",.22)
.....S PSBRTXTW=" Entered By "_PSBINIT_" on "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
.....N PSBEIECMT,PSBCMTCH S PSBEIECMT="",PSBCMTCH=0 F S PSBCMTCH=$O(^PSB(53.79,PSBIEN,.3,PSBCMTCH)) Q:'PSBCMTCH D
......I $P($G(^PSB(53.79,PSBIEN,.3,PSBCMTCH,0)),U)["**Pain Score of" S PSBEIECMT=" **This Pain Score may have been Entered in Error. See Vitals Package.**"
.....S PSBLINE2=PSBLINE2_PSBEIECMT
.....I PSBINIT[99 S PSBINIT=""
...S X=PSBADMDT D H^%DTC F PSBWEEK=+$G(PSBAR(%H)):-7 Q:$D(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",0))!('$D(PSBAR(PSBWEEK)))
...S X=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",""),-1)+1
...I PSBFLG="1" S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X)=PRELINE1
...S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+1)=PSBLINE1
...I $G(PSBLINE2)]"" D
....I $L(PSBLINE2)<=90 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=PSBLINE2 S:$$GET1^DIQ(53.79,PSBIEN_",",.24)'="" ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)=" "_PSBRTXTW
....I $L(PSBLINE2)>90 D
.....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=$E(PSBLINE2,1,90)
.....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)=" "_$E(PSBLINE2,91,169)
.....I $L(PSBLINE2)'>169 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)=" "_PSBRTXTW
.....I $L(PSBLINE2)>169 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)=" "_$E(PSBLINE2,170,245),^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+5)=" "_PSBRTXTW
D RELINE^PSBOMH3(PSBWEEK) ;Line up administrations with their admin times - PSB*3*67
Q
;
DDAUD ; audits for dispen drugs
;
N PSBMLA,PSBDATE,PSBGA,PSBTMP
M PSBMLA=^PSB(53.79,PSBIEN)
S PSBGA="" I $D(PSBMLA(.9,0)) D
.F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX)) I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D Q
..I $D(PSBMLA(.9,PSBX-2,0)) D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
..I '$D(PSBMLA(.9,PSBX-2,0)) S PSBDATE=$P(^PSB(53.79,PSBIEN,0),U,6)
..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
..S PSBGA=1
.F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX)) I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D
..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL^PSBRPC2($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2)
..S PSBGA=1
;PSB*3*45 Remove Use of $Q(<>,-1)
N PSBTMQ,PSBPQRY,PSBQRY
I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,7))
S PSBQRY="PSBTMP",PSBCNT=1 F S PSBTMQ=PSBQRY,PSBQRY=$Q(@PSBQRY) Q:PSBQRY="" D ; does comment go with action
.S PSBPQRY=$G(PSBTMQ)
.I PSBPQRY="" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; no prev action
.I $QS(PSBPQRY,2)="C" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; prev line = comment
.I $QS(PSBQRY,2)="C",$E($P(@PSBTMQ,U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@PSBTMQ,U,2)=$P(@PSBQRY,U,2) D Q
..S X=$P(@PSBQRY,U,4) S:X[":" X=$P(X,":",2) S $P(PSBTAR(PSBCNT-1),U,4)=X Q
.S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
Q
;
PSBOUT(PSBTET,PSBOT1) ;
I '$D(^PSB(53.79,PSBIEN,.9,0)) D PSBENT^PSBOMH2(PSBOT1)
N PSBIDA,PSBXA1,INSDD
S PSBIDA="" I $P(^PSB(53.79,PSBIEN,0),U,6)=PSBTET S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,7),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
S PSBXA1=0
F S PSBXA1=$O(^PSB(53.79,PSBIEN,.9,PSBXA1)) Q:+PSBXA1'>0 I PSBXA1'=0 D Q:$G(PSBOT1)["*"
.I $L(PSBXA1)<4 D
..I $P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1)=PSBTET D
...S:$G(PSBIDA)="" PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
...I (PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2)),$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",3)["Instruct" D
....S INSDD=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1),Y=INSDD D DD^%DT S INSDD=Y
....S PSBOT1=PSBOT1_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),U,3)_" "_INSDD
I $G(PSBIDA)="",$P(^PSB(53.79,PSBIEN,0),U,4)=PSBTET D
.S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
I $G(PSBNAME)="" D
. S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
S ^TMP("PSB",$J,"LEGEND",$S($G(PSBOT1)="":99,1:PSBOT1),PSBNAME)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOMH1 11938 printed Apr 09, 2024@20:45:40 Page 2
PSBOMH1 ;BIRMINGHAM/EFC-MAH ;Sep 01, 2020@15:11:32
+1 ;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,38,45,51,50,57,67,64,72,83,97,112,116,120,82**;Mar 2004;Build 27
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; ^DILF/2054
+6 ; File 200/10060
+7 ;
+8 ;*83 - add Remove events per Give events when occurred.
+9 ;
EN ;
+1 ; Load administrations
+2 NEW PSBDT,PSBADMDT,X,Y,I,S,PSBINIT,PSBNAME,PRELINE1,PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR,PSBLINE1,PSBLINE2,PSBRTXTW,PSBS,PSBTAR
+3 SET (PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR)=""
SET PSBDT=PSBSTRT
+4 ;ERROR
+5 FOR
SET PSBDT=$ORDER(^PSB(53.79,"AADT",DFN,PSBDT))
if 'PSBDT
QUIT
Begin DoDot:1
+6 ;Remove Lock as file is only read, PSB*3*64
FOR
SET PSBIEN=$ORDER(^PSB(53.79,"AADT",DFN,PSBDT,PSBIEN))
if 'PSBIEN
QUIT
if '$DATA(^PSB(53.79,PSBIEN))
QUIT
IF $PIECE(^PSB(53.79,PSBIEN,0),U,9)]""
Begin DoDot:2
+7 ; Bad IEN -no evnt dt
if '$PIECE($GET(^PSB(53.79,PSBIEN,0)),U,6)
QUIT
+8 ;NGiven
if $PIECE(^PSB(53.79,PSBIEN,0),U,9)="N"
QUIT
+9 SET PSBADMDT=PSBDT
IF $PIECE(^PSB(53.79,PSBIEN,0),U,9)="RM"
if (PSBDT>PSBSTOP)
SET PSBADMDT=+$$FINDGIVE^PSBUTL(PSBIEN)
IF ((PSBADMDT<PSBSTRT)!(PSBADMDT>PSBSTOP))&(PSBDT>PSBSTOP)
QUIT
+10 IF $PIECE(^PSB(53.79,PSBIEN,0),U,9)'="RM"
IF PSBDT>PSBSTOP
QUIT
+11 SET PSBORD=$PIECE($GET(^PSB(53.79,PSBIEN,.1)),U,1)
+12 ;PSB*3*45 Anyone on the audit log should be in the legend
+13 NEW TMPCT
SET TMPCT=0
FOR
SET TMPCT=$ORDER(^PSB(53.79,PSBIEN,.9,TMPCT))
if 'TMPCT
QUIT
Begin DoDot:3
+14 SET PSBINIT=$$GET1^DIQ(53.799,TMPCT_","_PSBIEN,"USER:INITIAL")
SET PSBNAME=$$GET1^DIQ(53.799,TMPCT_","_PSBIEN_",","USER")
+15 if PSBINIT=""
SET PSBINIT=99
+16 SET ^TMP("PSB",$JOB,"LEGEND",PSBINIT,PSBNAME)=""
End DoDot:3
+17 ; Continuous
+18 if $PIECE($GET(^PSB(53.79,PSBIEN,.1)),U,2)="C"
Begin DoDot:3
+19 SET X=PSBADMDT
DO H^%DTC
SET PSBWEEK=+$GET(PSBAR(%H))
DO CLEAN^PSBVT
DO PSJ1^PSBVT($PIECE(^PSB(53.79,PSBIEN,0),U,1),$PIECE(^PSB(53.79,PSBIEN,.1),U,1))
+20 ;chck IV audit
IF $PIECE(^PSB(53.79,PSBIEN,0),U,6)'=PSBDT
IF '$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH)
Begin DoDot:4
+21 SET PSBSIEN=PSBIEN
+22 IF $PIECE(^PSB(53.79,PSBIEN,0),"^",10)]""
DO BAGDTL^PSBRPC2(.PSBAUD,$PIECE(^PSB(53.79,PSBIEN,0),U,10),$PIECE(^PSB(53.79,PSBIEN,.1),U,1))
+23 SET PSBIEN=PSBSIEN
KILL PSBSIEN
+24 SET X=0
FOR
SET X=$ORDER(PSBAUD(X))
if X=""
QUIT
IF $PIECE(PSBAUD(X),U,3)=""
KILL PSBAUD(X)
+25 SET X=0
FOR
SET X=$ORDER(PSBAUD(X))
if X=""
QUIT
if $PIECE(PSBAUD(X),U,1)=PSBDT
QUIT
+26 IF X=""
KILL PSBAUD
QUIT
+27 IF '$DATA(PSBAUD(X))
KILL PSBAUD
QUIT
+28 SET PSBS=$PIECE(PSBAUD(X),U,3)
+29 IF PSBS="GIVEN"
IF $PIECE($GET(PSBAUD(X-1)),U,3)="NOT GIVEN"
QUIT
+30 IF PSBS="NOT GIVEN"
QUIT
+31 SET PSBS=$SELECT(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NOACTION")
+32 DO PSBSTIV^PSBOMH2
+33 SET X=PSBDT_U_$PIECE(PSBAUD(X),U,2)_U_PSBS_U_PSBIEN
+34 SET Y=$ORDER(^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
+35 ;PSB*3*67
SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT\1,Y)=X
+36 SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT\1,0)=Y
+37 DO PSBOUT($PIECE((X),"^",1),$PIECE((X),"^",2))
+38 KILL PSBAUD
End DoDot:4
DO CLEAN^PSBVT
QUIT
+39 ;Get initials of who took action, PSB*3*72
SET PSBINIT=$$GETINIT^PSBCSUTX(PSBIEN,"I")
+40 ;Get name of who took action, PSB*3*72
SET PSBNAME=$$GETINIT^PSBCSUTX(PSBIEN,"N")
+41 IF PSBINIT=""
SET PSBINIT=99
+42 ;get instrc info - audt log
+43 IF $DATA(^PSB(53.79,PSBIEN,.9,$PIECE(PSBDT,".")))
Begin DoDot:4
+44 DO INSTR^PSBOMH
+45 SET ^TMP("PSB",$JOB,"LEGEND",PSBINIT,PSBNAME)=""
End DoDot:4
+46 IF PSBINIT[99
SET PSBINIT=""
+47 IF $PIECE(^PSB(53.79,PSBIEN,0),U,9)="G"
IF PSBDT=$PIECE(^PSB(53.79,PSBIEN,0),U,6)
DO PSBCK1^PSBOMH2("A")
+48 IF $PIECE(^PSB(53.79,PSBIEN,0),U,9)'="G"
IF PSBDT=$PIECE(^PSB(53.79,PSBIEN,0),U,6)
DO PSBCK1^PSBOMH2("B")
+49 IF PSBDT'=$PIECE(^PSB(53.79,PSBIEN,0),U,6)
IF $PIECE(^PSB(53.79,PSBIEN,0),U,9)="RM"
Begin DoDot:4
+50 DO DDAUD
+51 SET I=""
FOR
SET I=$ORDER(PSBTAR(I),-1)
if I=""
QUIT
IF $PIECE(PSBTAR(I),U,1)=PSBDT
Begin DoDot:5
+52 SET PSBS=$PIECE(PSBTAR(I),U,3)
+53 ; canceled - not given
IF PSBS="GIVEN"
IF $PIECE($GET(PSBTAR(I-1)),U,3)="NOT GIVEN"
QUIT
+54 IF PSBS="NOT GIVEN"
QUIT
+55 SET PSBS=$SELECT(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NO ACTION")
+56 DO PSBCTAR^PSBOMH2
+57 SET X=$PIECE(PSBTAR(I),U,1,2)_U_PSBS_U_PSBIEN
End DoDot:5
End DoDot:4
+58 ;Quit if invalid data is returned, PSB*3*67
if '+X
QUIT
+59 ;
+60 ; PSB*3.0*82 - find all previous statuses, not just Given for Removed
+61 NEW PSB9CNT,PSB9REC,PSBOLDST,X2REC,X2,X2CNT
+62 SET PSB9CNT=0
+63 FOR
SET PSB9CNT=$ORDER(^PSB(53.79,PSBIEN,.9,PSB9CNT))
if 'PSB9CNT
QUIT
Begin DoDot:4
+64 SET PSB9REC=$GET(^PSB(53.79,PSBIEN,.9,PSB9CNT,0))
if PSB9REC']""
QUIT
+65 if PSB9REC'["ACTION STATUS Set to"
QUIT
+66 SET PSBOLDST=$EXTRACT($PIECE(PSB9REC,U,4),1,3)
if PSBOLDST="REM"
SET PSBOLDST="RM"
+67 if PSBOLDST'="RM"
SET PSBOLDST=$EXTRACT(PSBOLDST,1)
+68 SET X2REC=$PIECE(PSB9REC,U,1)_U_$PIECE($PIECE(PSB9REC,U,3),"'",4)_U_PSBOLDST_U_PSBIEN
+69 SET X2CNT=$ORDER(X2(""),-1)+1
SET X2(X2CNT)=X2REC
End DoDot:4
+70 SET X2CNT=$ORDER(X2(""),-1)
IF X2CNT]""
KILL X2(X2CNT)
+71 SET X2CNT=""
FOR
SET X2CNT=$ORDER(X2(X2CNT))
if X2CNT=""
QUIT
Begin DoDot:4
+72 SET X2REC=X2(X2CNT)
+73 if '$DATA(^TMP("PSB",$JOB,PSBWEEK,"HDR",$PIECE(X2REC,U)\1))
QUIT
+74 SET Y=$ORDER(^TMP("PSB",$JOB,PSBWEEK,PSBORD,$PIECE(X2REC,U)\1,""),-1)+1
+75 SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,$PIECE(X2REC,U)\1,Y)=X2REC
+76 SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,$PIECE(X2REC,U)\1,0)=Y
End DoDot:4
+77 SET Y=$ORDER(^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
+78 ;PSB*3*67
SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT\1,Y)=X
+79 SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT\1,0)=Y
+80 DO PSBOUT($PIECE((X),"^",1),$PIECE((X),"^",2))
+81 QUIT
End DoDot:3
+82 ;
+83 ; 1-Time On Call or PRN
+84 if $PIECE($GET(^PSB(53.79,PSBIEN,.1)),U,2)'="C"
Begin DoDot:3
+85 IF PSBDT'=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I")
QUIT
+86 ;Get initials of who took action, PSB*3*72
SET PSBINIT=$$GETINIT^PSBCSUTX(PSBIEN,"I")
+87 ;Get name of who took action, PSB*3*72
SET PSBNAME=$$GETINIT^PSBCSUTX(PSBIEN,"N")
+88 IF PSBINIT=""
SET PSBINIT=99
+89 NEW PSBXA,PSBM,PSBZ,PSBT,PSBFLG
+90 SET (PSBXA,PSBM)=1
SET (PSBZ,PSBT,PSBFLG)=""
+91 IF $$GET1^DIQ(53.79,PSBIEN_",",.09)="REMOVED"
Begin DoDot:4
+92 FOR I=1:1
SET PSBXA=$ORDER(^PSB(53.79,PSBIEN,.9,PSBXA))
if PSBXA=""
QUIT
IF PSBXA?1.3N
SET PSBZ=PSBZ+1
SET PSBT(PSBZ)=^PSB(53.79,PSBIEN,.9,PSBXA,0)
+93 FOR S=1:1
if PSBM<1
QUIT
SET PSBM=PSBZ-S
IF (PSBM>0)
IF (PSBT(PSBM)["GIVEN")
SET PSBFLG="1"
SET PRELINE1=$PIECE(PSBT(PSBM),"'",2)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.04)_" "_$EXTRACT($PIECE(PSBT(PSBM),"'",4),1,3)
QUIT
End DoDot:4
+94 IF $DATA(^PSB(53.79,PSBIEN,.9,$PIECE(PSBDT,".")))
Begin DoDot:4
+95 DO INSTR^PSBOMH
+96 SET ^TMP("PSB",$JOB,"LEGEND",PSBINIT,PSBNAME)=""
End DoDot:4
+97 IF '$DATA(^PSB(53.79,PSBIEN,.9,$PIECE(PSBDT,".")))
DO PSBOUT(PSBDT,PSBINIT)
+98 SET PSBLINE1=$$GET1^DIQ(53.79,PSBIEN_",",.09)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.06)_" "_PSBINIT_" "_$$GET1^DIQ(53.79,PSBIEN_",",.21)
SET PSBLINE2=""
+99 IF PSBINIT[99
SET PSBINIT=""
+100 if $PIECE($GET(^PSB(53.79,PSBIEN,.1)),U,2)="P"
Begin DoDot:4
+101 IF $PIECE($GET(^PSB(53.79,PSBIEN,.2)),U,2)=""
SET PSBLINE2=" Results: <No PRN Results On File>"
+102 IF '$TEST
Begin DoDot:5
+103 SET PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:INITIAL")
+104 SET PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:NAME")
+105 IF PSBINIT=""
SET PSBINIT=99
+106 IF $DATA(^PSB(53.79,PSBIEN,.9,$PIECE(PSBDT,".")))
Begin DoDot:6
+107 SET PSBINIT=PSBINIT_"*"
SET PSBNAME=PSBNAME_"/"_$PIECE(^PSB(53.79,PSBIEN,.9,$PIECE(PSBDT,"."),0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
+108 SET ^TMP("PSB",$JOB,"LEGEND",PSBINIT,PSBNAME)=""
End DoDot:6
+109 IF '$DATA(^PSB(53.79,PSBIEN,.9,$PIECE(PSBDT,".")))
Begin DoDot:6
+110 if $DATA(^PSB(53.79,PSBIEN,.9,0))
Begin DoDot:7
+111 NEW PSBXA2,PSBFG,PSBEFFDT
+112 SET (PSBXA2,PSBFG)=0
SET PSBEFFDT=$PIECE(^PSB(53.79,PSBIEN,.2),U,4)
FOR
SET PSBXA2=$ORDER(^PSB(53.79,PSBIEN,.9,PSBXA2))
if +PSBXA2'>0
QUIT
Begin DoDot:8
+113 if ($PIECE(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U)=PSBEFFDT)&($PIECE(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)["Instruct")&($PIECE(^PSB(53.79,PSBIEN,.2),U,3)=$PIECE(^PSB(53.79,PSBIEN,.9,PS
BXA2,0),U,2))
Begin DoDot:9
+114 SET PSBINIT=PSBINIT_"*"
SET PSBNAME=PSBNAME_"/"_$PIECE(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
+115 SET ^TMP("PSB",$JOB,"LEGEND",PSBINIT,PSBNAME)=""
SET PSBFG=1
End DoDot:9
End DoDot:8
if PSBFG=1
QUIT
End DoDot:7
End DoDot:6
+116 SET PSBLINE2=" Results: "_$$GET1^DIQ(53.79,PSBIEN_",",.22)
+117 SET PSBRTXTW=" Entered By "_PSBINIT_" on "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
+118 NEW PSBEIECMT,PSBCMTCH
SET PSBEIECMT=""
SET PSBCMTCH=0
FOR
SET PSBCMTCH=$ORDER(^PSB(53.79,PSBIEN,.3,PSBCMTCH))
if 'PSBCMTCH
QUIT
Begin DoDot:6
+119 IF $PIECE($GET(^PSB(53.79,PSBIEN,.3,PSBCMTCH,0)),U)["**Pain Score of"
SET PSBEIECMT=" **This Pain Score may have been Entered in Error. See Vitals Package.**"
End DoDot:6
+120 SET PSBLINE2=PSBLINE2_PSBEIECMT
+121 IF PSBINIT[99
SET PSBINIT=""
End DoDot:5
End DoDot:4
+122 SET X=PSBADMDT
DO H^%DTC
FOR PSBWEEK=+$GET(PSBAR(%H)):-7
if $DATA(^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",0))!('$DATA(PSBAR(PSBWEEK)))
QUIT
+123 SET X=$ORDER(^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",""),-1)+1
+124 IF PSBFLG="1"
SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",X)=PRELINE1
+125 SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",X+1)=PSBLINE1
+126 IF $GET(PSBLINE2)]""
Begin DoDot:4
+127 IF $LENGTH(PSBLINE2)<=90
SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",X+2)=PSBLINE2
if $$GET1^DIQ(53.79,PSBIEN_",",.24)'=""
SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",X+3)=" "_PSBRTXTW
+128 IF $LENGTH(PSBLINE2)>90
Begin DoDot:5
+129 SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",X+2)=$EXTRACT(PSBLINE2,1,90)
+130 SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",X+3)=" "_$EXTRACT(PSBLINE2,91,169)
+131 IF $LENGTH(PSBLINE2)'>169
SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",X+4)=" "_PSBRTXTW
+132 IF $LENGTH(PSBLINE2)>169
SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",X+4)=" "_$EXTRACT(PSBLINE2,170,245)
SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",X+5)=" "_PSBRTXTW
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+133 ;Line up administrations with their admin times - PSB*3*67
DO RELINE^PSBOMH3(PSBWEEK)
+134 QUIT
+135 ;
DDAUD ; audits for dispen drugs
+1 ;
+2 NEW PSBMLA,PSBDATE,PSBGA,PSBTMP
+3 MERGE PSBMLA=^PSB(53.79,PSBIEN)
+4 SET PSBGA=""
IF $DATA(PSBMLA(.9,0))
Begin DoDot:1
+5 FOR PSBX=1:1
if '$DATA(PSBMLA(.9,PSBX))
QUIT
IF ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS"))
Begin DoDot:2
+6 IF $DATA(PSBMLA(.9,PSBX-2,0))
DO DT^DILF("ENPST",$PIECE(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
+7 IF '$DATA(PSBMLA(.9,PSBX-2,0))
SET PSBDATE=$PIECE(^PSB(53.79,PSBIEN,0),U,6)
+8 SET PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL^PSBRPC2($PIECE(PSBMLA(0),U,5))_U_$PIECE(PSBMLA(.9,PSBX,0),"'",2)
+9 SET PSBGA=1
End DoDot:2
QUIT
+10 FOR PSBX=1:1
if '$DATA(PSBMLA(.9,PSBX))
QUIT
IF ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS"))
Begin DoDot:2
+11 SET PSBTMP(10000000-$PIECE(PSBMLA(.9,PSBX,0),U,1),"B")=$PIECE(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL^PSBRPC2($PIECE(PSBMLA(.9,PSBX,0),U,2))_U_$PIECE($PIECE(PSBMLA(.9,PSBX,0),U,3),"'",2)
+12 SET PSBGA=1
End DoDot:2
End DoDot:1
+13 ;PSB*3*45 Remove Use of $Q(<>,-1)
+14 NEW PSBTMQ,PSBPQRY,PSBQRY
+15 IF PSBGA'=1
SET PSBTMP(10000000-$PIECE(PSBMLA(0),U,6),"A")=$PIECE(PSBMLA(0),U,6)_U_$$INITIAL^PSBRPC2($PIECE(PSBMLA(0),U,7))
+16 ; does comment go with action
SET PSBQRY="PSBTMP"
SET PSBCNT=1
FOR
SET PSBTMQ=PSBQRY
SET PSBQRY=$QUERY(@PSBQRY)
if PSBQRY=""
QUIT
Begin DoDot:1
+17 SET PSBPQRY=$GET(PSBTMQ)
+18 ; no prev action
IF PSBPQRY=""
SET PSBTAR(PSBCNT)=@PSBQRY
SET PSBCNT=PSBCNT+1
QUIT
+19 ; prev line = comment
IF $QSUBSCRIPT(PSBPQRY,2)="C"
SET PSBTAR(PSBCNT)=@PSBQRY
SET PSBCNT=PSBCNT+1
QUIT
+20 IF $QSUBSCRIPT(PSBQRY,2)="C"
IF $EXTRACT($PIECE(@PSBTMQ,U,1),1,12)=$EXTRACT($PIECE(@PSBQRY,U,1),1,12)
IF $PIECE(@PSBTMQ,U,2)=$PIECE(@PSBQRY,U,2)
Begin DoDot:2
+21 SET X=$PIECE(@PSBQRY,U,4)
if X["
SET X=$PIECE(X,":",2)
SET $PIECE(PSBTAR(PSBCNT-1),U,4)=X
QUIT
End DoDot:2
QUIT
+22 SET PSBTAR(PSBCNT)=@PSBQRY
SET PSBCNT=PSBCNT+1
End DoDot:1
+23 QUIT
+24 ;
PSBOUT(PSBTET,PSBOT1) ;
+1 IF '$DATA(^PSB(53.79,PSBIEN,.9,0))
DO PSBENT^PSBOMH2(PSBOT1)
+2 NEW PSBIDA,PSBXA1,INSDD
+3 SET PSBIDA=""
IF $PIECE(^PSB(53.79,PSBIEN,0),U,6)=PSBTET
SET PSBIDA=$PIECE(^PSB(53.79,PSBIEN,0),U,7)
SET PSBOT1=$PIECE(^VA(200,PSBIDA,0),"^",2)
SET PSBNAME=$PIECE(^VA(200,PSBIDA,0),"^",1)
+4 SET PSBXA1=0
+5 FOR
SET PSBXA1=$ORDER(^PSB(53.79,PSBIEN,.9,PSBXA1))
if +PSBXA1'>0
QUIT
IF PSBXA1'=0
Begin DoDot:1
+6 IF $LENGTH(PSBXA1)<4
Begin DoDot:2
+7 IF $PIECE(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1)=PSBTET
Begin DoDot:3
+8 if $GET(PSBIDA)=""
SET PSBIDA=$PIECE(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2)
SET PSBOT1=$PIECE(^VA(200,PSBIDA,0),"^",2)
SET PSBNAME=$PIECE(^VA(200,PSBIDA,0),"^",1)
+9 IF (PSBIDA=$PIECE(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2))
IF $PIECE(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",3)["Instruct"
Begin DoDot:4
+10 SET INSDD=$PIECE(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1)
SET Y=INSDD
DO DD^%DT
SET INSDD=Y
+11 SET PSBOT1=PSBOT1_"*"
SET PSBNAME=PSBNAME_"/"_$PIECE(^PSB(53.79,PSBIEN,.9,PSBXA1,0),U,3)_" "_INSDD
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
if $GET(PSBOT1)["*"
QUIT
+12 IF $GET(PSBIDA)=""
IF $PIECE(^PSB(53.79,PSBIEN,0),U,4)=PSBTET
Begin DoDot:1
+13 SET PSBIDA=$PIECE(^PSB(53.79,PSBIEN,0),U,5)
SET PSBOT1=$PIECE(^VA(200,PSBIDA,0),"^",2)
SET PSBNAME=$PIECE(^VA(200,PSBIDA,0),"^",1)
End DoDot:1
+14 IF $GET(PSBNAME)=""
Begin DoDot:1
+15 SET PSBIDA=$PIECE(^PSB(53.79,PSBIEN,0),U,5)
SET PSBOT1=$PIECE(^VA(200,PSBIDA,0),"^",2)
SET PSBNAME=$PIECE(^VA(200,PSBIDA,0),"^",1)
End DoDot:1
+16 SET ^TMP("PSB",$JOB,"LEGEND",$SELECT($GET(PSBOT1)="":99,1:PSBOT1),PSBNAME)=""
+17 QUIT
