PSBOMH1 ;BIRMINGHAM/EFC-MAH ; 1/7/09 9:27am
;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,38,45,51,50**;Mar 2004;Build 78
;Per VHA Directive 2004-038, this routine should not be modified.
;
; Reference/IA
; ^DILF/2054
; File 200/10060
;
EN ;
; Load administrations
S (PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR)="",PSBDT=PSBSTRT
K PSBTSA
F S PSBDT=$O(^PSB(53.79,"AADT",DFN,PSBDT)) Q:'PSBDT!(PSBDT>PSBSTOP) D
.F S PSBIEN=$O(^PSB(53.79,"AADT",DFN,PSBDT,PSBIEN)) Q:'PSBIEN Q:'$D(^PSB(53.79,PSBIEN)) L +^PSB(53.79,PSBIEN):3 I $P(^PSB(53.79,PSBIEN,0),U,9)]"" D L -^PSB(53.79,PSBIEN)
..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 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=PSBDT D H^%DTC S PSBWEEK=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
....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
....D PSBOUT($P((X),"^",1),$P((X),"^",2))
....K PSBAUD
...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
...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
...S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
...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=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
...I PSBINIT="" S PSBINIT=99
...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))
.......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=PSBDT D H^%DTC F PSBWEEK=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
Q
;
DDAUD ; audits for dispen drugs
;
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
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)
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
;
PSBOMH1 ;BIRMINGHAM/EFC-MAH ; 1/7/09 9:27am
+1 ;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,38,45,51,50**;Mar 2004;Build 78
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; ^DILF/2054
+6 ; File 200/10060
+7 ;
EN ;
+1 ; Load administrations
+2 SET (PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR)=""
SET PSBDT=PSBSTRT
+3 KILL PSBTSA
+4 FOR
SET PSBDT=$ORDER(^PSB(53.79,"AADT",DFN,PSBDT))
IF 'PSBDT!(PSBDT>PSBSTOP)
QUIT
Begin DoDot:1
+5 FOR
SET PSBIEN=$ORDER(^PSB(53.79,"AADT",DFN,PSBDT,PSBIEN))
IF 'PSBIEN
QUIT
IF '$DATA(^PSB(53.79,PSBIEN))
QUIT
LOCK +^PSB(53.79,PSBIEN):3
IF $PIECE(^PSB(53.79,PSBIEN,0),U,9)]""
Begin DoDot:2
+6 ; Bad IEN -no evnt dt
IF '$PIECE($GET(^PSB(53.79,PSBIEN,0)),U,6)
QUIT
+7 ;NGiven
IF $PIECE(^PSB(53.79,PSBIEN,0),U,9)="N"
QUIT
+8 SET PSBORD=$PIECE($GET(^PSB(53.79,PSBIEN,.1)),U,1)
+9 ;PSB*3*45 Anyone on the audit log should be in the legend
+10 NEW TMPCT
SET TMPCT=0
FOR
SET TMPCT=$ORDER(^PSB(53.79,PSBIEN,.9,TMPCT))
IF 'TMPCT
QUIT
Begin DoDot:3
+11 SET PSBINIT=$$GET1^DIQ(53.799,TMPCT_","_PSBIEN,"USER:INITIAL")
SET PSBNAME=$$GET1^DIQ(53.799,TMPCT_","_PSBIEN_",","USER")
+12 IF PSBINIT=""
SET PSBINIT=99
+13 SET ^TMP("PSB",$JOB,"LEGEND",PSBINIT,PSBNAME)=""
End DoDot:3
+14 ; Continuous
+15 IF $PIECE($GET(^PSB(53.79,PSBIEN,.1)),U,2)="C"
Begin DoDot:3
+16 SET X=PSBDT
DO H^%DTC
SET PSBWEEK=PSBAR(%H)
DO CLEAN^PSBVT
DO PSJ1^PSBVT($PIECE(^PSB(53.79,PSBIEN,0),U,1),$PIECE(^PSB(53.79,PSBIEN,.1),U,1))
+17 ;chck IV audit
IF $PIECE(^PSB(53.79,PSBIEN,0),U,6)'=PSBDT
IF '$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH)
Begin DoDot:4
+18 SET PSBSIEN=PSBIEN
+19 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))
+20 SET PSBIEN=PSBSIEN
KILL PSBSIEN
+21 SET X=0
FOR
SET X=$ORDER(PSBAUD(X))
IF X=""
QUIT
IF $PIECE(PSBAUD(X),U,3)=""
KILL PSBAUD(X)
+22 SET X=0
FOR
SET X=$ORDER(PSBAUD(X))
IF X=""
QUIT
IF $PIECE(PSBAUD(X),U,1)=PSBDT
QUIT
+23 IF X=""
KILL PSBAUD
QUIT
+24 IF '$DATA(PSBAUD(X))
KILL PSBAUD
QUIT
+25 SET PSBS=$PIECE(PSBAUD(X),U,3)
+26 IF PSBS="GIVEN"
IF $PIECE($GET(PSBAUD(X-1)),U,3)="NOT GIVEN"
QUIT
+27 IF PSBS="NOT GIVEN"
QUIT
+28 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")
+29 DO PSBSTIV^PSBOMH2
+30 SET X=PSBDT_U_$PIECE(PSBAUD(X),U,2)_U_PSBS_U_PSBIEN
+31 SET Y=$ORDER(^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
+32 SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT\1,Y)=X
+33 SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT\1,0)=Y
+34 DO PSBOUT($PIECE((X),"^",1),$PIECE((X),"^",2))
+35 KILL PSBAUD
End DoDot:4
DO CLEAN^PSBVT
QUIT
+36 SET PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
+37 SET PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
+38 IF PSBINIT=""
SET PSBINIT=99
+39 ;get instrc info - audt log
+40 IF $DATA(^PSB(53.79,PSBIEN,.9,$PIECE(PSBDT,".")))
Begin DoDot:4
+41 DO INSTR^PSBOMH
+42 SET ^TMP("PSB",$JOB,"LEGEND",PSBINIT,PSBNAME)=""
End DoDot:4
+43 IF PSBINIT[99
SET PSBINIT=""
+44 IF $PIECE(^PSB(53.79,PSBIEN,0),U,9)="G"
IF PSBDT=$PIECE(^PSB(53.79,PSBIEN,0),U,6)
DO PSBCK1^PSBOMH2("A")
+45 IF $PIECE(^PSB(53.79,PSBIEN,0),U,9)'="G"
IF PSBDT=$PIECE(^PSB(53.79,PSBIEN,0),U,6)
DO PSBCK1^PSBOMH2("B")
+46 IF PSBDT'=$PIECE(^PSB(53.79,PSBIEN,0),U,6)
IF $PIECE(^PSB(53.79,PSBIEN,0),U,9)="RM"
Begin DoDot:4
+47 DO DDAUD
+48 SET I=""
FOR
SET I=$ORDER(PSBTAR(I),-1)
IF I=""
QUIT
IF $PIECE(PSBTAR(I),U,1)=PSBDT
Begin DoDot:5
+49 SET PSBS=$PIECE(PSBTAR(I),U,3)
+50 ; canceled - not given
IF PSBS="GIVEN"
IF $PIECE($GET(PSBTAR(I-1)),U,3)="NOT GIVEN"
QUIT
+51 IF PSBS="NOT GIVEN"
QUIT
+52 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")
+53 DO PSBCTAR^PSBOMH2
+54 SET X=$PIECE(PSBTAR(I),U,1,2)_U_PSBS_U_PSBIEN
End DoDot:5
End DoDot:4
+55 SET Y=$ORDER(^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
+56 SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT\1,Y)=X
+57 SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDT\1,0)=Y
+58 DO PSBOUT($PIECE((X),"^",1),$PIECE((X),"^",2))
+59 QUIT
End DoDot:3
+60 ; 1-Time On Call or PRN
+61 IF $PIECE($GET(^PSB(53.79,PSBIEN,.1)),U,2)'="C"
Begin DoDot:3
+62 IF PSBDT'=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I")
QUIT
+63 SET PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
+64 SET PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
+65 IF PSBINIT=""
SET PSBINIT=99
+66 SET (PSBXA,PSBM)=1
SET (PSBZ,PSBT,PSBFLG)=""
+67 IF $$GET1^DIQ(53.79,PSBIEN_",",.09)="REMOVED"
Begin DoDot:4
+68 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)
+69 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
+70 IF $DATA(^PSB(53.79,PSBIEN,.9,$PIECE(PSBDT,".")))
Begin DoDot:4
+71 DO INSTR^PSBOMH
+72 SET ^TMP("PSB",$JOB,"LEGEND",PSBINIT,PSBNAME)=""
End DoDot:4
+73 IF '$DATA(^PSB(53.79,PSBIEN,.9,$PIECE(PSBDT,".")))
DO PSBOUT(PSBDT,PSBINIT)
+74 SET PSBLINE1=$$GET1^DIQ(53.79,PSBIEN_",",.09)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.06)_" "_PSBINIT_" "_$$GET1^DIQ(53.79,PSBIEN_",",.21)
SET PSBLINE2=""
+75 IF PSBINIT[99
SET PSBINIT=""
+76 IF $PIECE($GET(^PSB(53.79,PSBIEN,.1)),U,2)="P"
Begin DoDot:4
+77 IF $PIECE($GET(^PSB(53.79,PSBIEN,.2)),U,2)=""
SET PSBLINE2=" Results: <No PRN Results On File>"
+78 IF '$TEST
Begin DoDot:5
+79 SET PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:INITIAL")
+80 SET PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:NAME")
+81 IF PSBINIT=""
SET PSBINIT=99
+82 IF $DATA(^PSB(53.79,PSBIEN,.9,$PIECE(PSBDT,".")))
Begin DoDot:6
+83 SET PSBINIT=PSBINIT_"*"
SET PSBNAME=PSBNAME_"/"_$PIECE(^PSB(53.79,PSBIEN,.9,$PIECE(PSBDT,"."),0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
+84 SET ^TMP("PSB",$JOB,"LEGEND",PSBINIT,PSBNAME)=""
End DoDot:6
+85 IF '$DATA(^PSB(53.79,PSBIEN,.9,$PIECE(PSBDT,".")))
Begin DoDot:6
+86 IF $DATA(^PSB(53.79,PSBIEN,.9,0))
Begin DoDot:7
+87 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
+88 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
+89 SET PSBINIT=PSBINIT_"*"
SET PSBNAME=PSBNAME_"/"_$PIECE(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
+90 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
+91 SET PSBLINE2=" Results: "_$$GET1^DIQ(53.79,PSBIEN_",",.22)
+92 SET PSBRTXTW=" Entered By "_PSBINIT_" on "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
+93 NEW PSBEIECMT,PSBCMTCH
SET PSBEIECMT=""
SET PSBCMTCH=0
FOR
SET PSBCMTCH=$ORDER(^PSB(53.79,PSBIEN,.3,PSBCMTCH))
IF 'PSBCMTCH
QUIT
Begin DoDot:6
+94 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
+95 SET PSBLINE2=PSBLINE2_PSBEIECMT
+96 IF PSBINIT[99
SET PSBINIT=""
End DoDot:5
End DoDot:4
+97 SET X=PSBDT
DO H^%DTC
FOR PSBWEEK=PSBAR(%H):-7
IF $DATA(^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",0))!('$DATA(PSBAR(PSBWEEK)))
QUIT
+98 SET X=$ORDER(^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",""),-1)+1
+99 IF PSBFLG="1"
SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",X)=PRELINE1
+100 SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",X+1)=PSBLINE1
+101 IF $GET(PSBLINE2)]""
Begin DoDot:4
+102 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
+103 IF $LENGTH(PSBLINE2)>90
Begin DoDot:5
+104 SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",X+2)=$EXTRACT(PSBLINE2,1,90)
+105 SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",X+3)=" "_$EXTRACT(PSBLINE2,91,169)
+106 IF $LENGTH(PSBLINE2)'>169
SET ^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",X+4)=" "_PSBRTXTW
+107 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
LOCK -^PSB(53.79,PSBIEN)
End DoDot:1
+108 QUIT
+109 ;
DDAUD ; audits for dispen drugs
+1 ;
+2 MERGE PSBMLA=^PSB(53.79,PSBIEN)
+3 SET PSBGA=""
IF $DATA(PSBMLA(.9,0))
Begin DoDot:1
+4 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
+5 IF $DATA(PSBMLA(.9,PSBX-2,0))
DO DT^DILF("ENPST",$PIECE(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
+6 IF '$DATA(PSBMLA(.9,PSBX-2,0))
SET PSBDATE=$PIECE(^PSB(53.79,PSBIEN,0),U,6)
+7 SET PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL^PSBRPC2($PIECE(PSBMLA(0),U,5))_U_$PIECE(PSBMLA(.9,PSBX,0),"'",2)
+8 SET PSBGA=1
End DoDot:2
QUIT
+9 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
+10 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)
+11 SET PSBGA=1
End DoDot:2
End DoDot:1
+12 ;PSB*3*45 Remove Use of $Q(<>,-1)
+13 NEW PSBTMQ
+14 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))
+15 ; 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
+16 SET PSBPQRY=$GET(PSBTMQ)
+17 ; no prev action
IF PSBPQRY=""
SET PSBTAR(PSBCNT)=@PSBQRY
SET PSBCNT=PSBCNT+1
QUIT
+18 ; prev line = comment
IF $QSUBSCRIPT(PSBPQRY,2)="C"
SET PSBTAR(PSBCNT)=@PSBQRY
SET PSBCNT=PSBCNT+1
QUIT
+19 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
+20 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
+21 SET PSBTAR(PSBCNT)=@PSBQRY
SET PSBCNT=PSBCNT+1
End DoDot:1
+22 QUIT
+23 ;
PSBOUT(PSBTET,PSBOT1) ;
+1 IF '$DATA(^PSB(53.79,PSBIEN,.9,0))
DO PSBENT^PSBOMH2(PSBOT1)
+2 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)
+3 SET PSBXA1=0
+4 FOR
SET PSBXA1=$ORDER(^PSB(53.79,PSBIEN,.9,PSBXA1))
IF +PSBXA1'>0
QUIT
IF PSBXA1'=0
Begin DoDot:1
+5 IF $LENGTH(PSBXA1)<4
Begin DoDot:2
+6 IF $PIECE(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1)=PSBTET
Begin DoDot:3
+7 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)
+8 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
+9 SET INSDD=$PIECE(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1)
SET Y=INSDD
DO DD^%DT
SET INSDD=Y
+10 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
+11 IF $GET(PSBIDA)=""
IF $PIECE(^PSB(53.79,PSBIEN,0),U,4)=PSBTET
Begin DoDot:1
+12 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
+13 IF $GET(PSBNAME)=""
Begin DoDot:1
+14 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
+15 SET ^TMP("PSB",$JOB,"LEGEND",$SELECT($GET(PSBOT1)="":99,1:PSBOT1),PSBNAME)=""
+16 QUIT
+17 ;
