- 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 ;
