PSBOMH1.m

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 ---PSBOMH1   11938     printed  Feb 18, 2025@23:07:02                                                                                                                                                                                                    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)