PSBOCM1 ;BIRMINGHAM/TEJ-COVERSHEET MEDICATION OVERVIEW REPORT ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**32,50**;Mar 2004;Build 78
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
BUILDLN ; Constr recs
K J S J(0)="" F PSBFLD=1:1:8 S J=1 D FORMDAT(PSBFLD) S J($O(PSBRPLN(""),-1))=""
; Write administration info...
Q:'PSBXFLG
S J=($O(J(""),-1)+1),PSBRPLN(J)=PSBBLANK,J(J)="",J=J+1
S (N,Y)="",J=($O(J(""),-1)+1)
F S Y=$O(PSBADM(PSBX2X,Y)) Q:Y']"" D
.F S N=$O(PSBADM(PSBX2X,Y,N)) Q:N']"" D
..I $D(PSBBID(PSBX2X,$P(N,U,2))) S PSBDATA(2,0)="BAG ID: "_PSBBID(PSBX2X,$P(N,U,2))
..S $E(PSBDATA(2,0),25)="ACTION BY: "_$P(PSBADM(PSBX2X,Y,N),U,7)_" "_$$FMTDT^PSBOCE1($E($P(PSBADM(PSBX2X,Y,N),U,6),1,12))
..S X=$P(PSBADM(PSBX2X,Y,N),U,5) S $E(PSBDATA(2,0),56)="ACTION: "_$S(X="G":"GIVEN",X="R":"REFUSED",X="RM":"REMOVED",X="H":"HELD",X="S":"STOPPED",X="I":"INFUSING",X="C":"COMPLETED",X="M":"MISSING DOSE",X=" ":"*UNKNOWN*",1:" ")
..I $D(PSBPRNR(PSBX2X)) S $E(PSBDATA(2,0),72)="PRN REASON: "_PSBPRNR(PSBX2X,$P(N,U,2))
..I $G(PSBDATA(2,0))]" " D WRAPPER(1,132-1,PSBDATA(2,0)) K PSBDATA(2) S J=J+1
..N PSBEIECMT S PSBEIECMT="" I $D(PSBPRNEF(PSBX2X,$P(N,U,2))),$P($G(PSBRPT(.2)),U,8)=0 S PSBEIECMT=$$PRNEFF^PSBO(PSBEIECMT,$P(N,U,2))
..I $D(PSBPRNEF(PSBX2X,$P(N,U,2))) S PSBDATA(2,0)="PRN EFFECTIVENESS: "_PSBPRNEF(PSBX2X,$P(N,U,2))_PSBEIECMT
..I $G(PSBDATA(2,0))]" " D WRAPPER(30,132-30,PSBDATA(2,0)) K PSBDATA(2) S J=J+1
..I ('PSBCFLG)!('$D(PSBCMT(PSBX2X,$P(N,U,2)))) S PSBRPLN(J)=PSBBLANK,J(J)="",J=J+1 Q
..S X="" F S X=$O(PSBCMT(PSBX2X,$P(N,U,2),X)) Q:X']"" D
...N PSBDAT S PSBDAT="" F S PSBDAT=$O(PSBCMT(PSBX2X,$P(N,U,2),X,PSBDAT)) Q:PSBDAT']"" D
....S PSBDATA(2,0)="COMMENT BY: "_$S($P(PSBCMT(PSBX2X,$P(N,U,2),X,PSBDAT),U,5)]"":$P(PSBCMT(PSBX2X,$P(N,U,2),X,PSBDAT),U,5)_" "_$$FMTDT^PSBOCE1($E($P(PSBCMT(PSBX2X,$P(N,U,2),X,PSBDAT),U,6),1,12)),1:" n/a ")
....S PSBDATA(2,0)=PSBDATA(2,0)_" COMMENT: "_$S($P(PSBCMT(PSBX2X,$P(N,U,2),X,PSBDAT),U,2)]"":$P(PSBCMT(PSBX2X,$P(N,U,2),X,PSBDAT),U,2),1:" ")
....I $G(PSBDATA(2,0))]" " D WRAPPER(30,132-30,PSBDATA(2,0)) K PSBDATA(2) S J=J+1
..S PSBRPLN(J)=PSBBLANK,J(J)="",J=J+1
Q
FORMDAT(FLD) ;
K PSBVAL
Q:'$D(PSBDATA(1,FLD))
S PSBVAL=PSBDATA(1,FLD)
D WRAPPER(@("PSBTAB"_(FLD-1))+1,((@("PSBTAB"_(FLD))-(@("PSBTAB"_(FLD-1))+1))),PSBVAL)
I FLD=4 S J=$O(J(""),-1)+1,PSBVAL=PSBDATA(1,4,0) D WRAPPER(@("PSBTAB"_(FLD-1))+1,((@("PSBTAB"_(FLD))-(@("PSBTAB"_(FLD-1))+1))),PSBVAL)
Q
WRAPPER(X,Y,Z) ; Text WRAP
N PSB
I ($L(Z)>0),$F(Z,"""")>1 F Q:$F(Z,"""")'>1 S Z=$TR(Z,"""","^")
F Q:'$L(Z) D
.I $L(Z)<Y S $E(PSBRPLN(J),X)=Z S Z="" D Q
..I $L(PSBRPLN(J),"^")>1 F X=1:1:$L(PSBRPLN(J),"^")-1 S $P(PSBRPLN(J),"^",X)=$P(PSBRPLN(J),"^",X)_""""
..S PSBRPLN(J)=$TR(PSBRPLN(J),"^","""")
.F PSB=Y:-1:0 Q:($E(Z,PSB)=" ") Q:($E(Z,PSB)="-")
.S:PSB<1 PSB=Y
.S $E(PSBRPLN(J),X)=$E(Z,1,PSB)
.S Z=$E(Z,PSB+1,250)
.I $L(PSBRPLN(J),"^")>1 F X=1:1:$L(PSBRPLN(J),"^")-1 S $P(PSBRPLN(J),"^",X)=$P(PSBRPLN(J),"^",X)_""""
.S PSBRPLN(J)=$TR(PSBRPLN(J),"^","""")
.S J=J+1,J(J)=""
Q ""
CREATHDR ;
K PSBHD1,PSBHD2
I IOM'<132 S PSBHD1=$P($T(HD132A),"~",2),PSBHD2=$P($T(HD132B),";",2),PSBBLANK=$P($T(C132BLK),";",2)
E S PSBHD1="THIS REPORT SUPPORTS >131 CHAR./LINE PRINT FORMATS ONLY" Q
; reset tabs
S PSBTAB0=1 F PSBI=0:1:($L(PSBHD1,"|")-1) S:PSBI>0 @("PSBTAB"_PSBI)=($F(PSBHD1,"|",@("PSBTAB"_(PSBI-1))+1))-1
S PSBPGNUM=1
D HDR
Q
HD132A ;~VDL | Order |Type| Medication; Dosage, Route | Schedule | Next Action | Order Start | Order Stop |
Q
HD132B ;Tab | Status | | | | | Date | Date |
Q
C132BLK ;;
Q
WRTRPT ; writ
I $O(PSBOUTP(""),-1)<1 D Q
.X PSBOUTP($O(PSBOUTP(""),-1),14)
.D FTR
S PSBPGNUM=1
S PSBZ="" F S PSBZ=$O(PSBOUTP(PSBZ)) Q:PSBZ="" D
.I PSBPGNUM'=PSBZ D FTR S PSBPGNUM=PSBZ D HDR,SUBHDR^PSBOCE
.S PSBX2X="" F S PSBX2X=$O(PSBOUTP(PSBZ,PSBX2X)) Q:PSBX2X="" D
..X PSBOUTP(PSBZ,PSBX2X)
D FTR
K ^XTMP("PSBO",$J,"PSBLIST"),PSBOUTP
Q
HDR ; Header
W:$Y>1 @IOF
W:$X>1 !
S PSBRPNM="BCMA COVERSHEET MEDICATION OVERVIEW REPORT"
D:$P(PSBRPT(.1),U,1)="P"
.S PSBHDR(0)=PSBRPNM
.S PSBHDR(1)="Order Status(es): --"
.F Y=4,5,7,8 I $P(PSBFUTR,U,Y) S $P(PSBHDR(1),": ",2)=$P(PSBHDR(1),": ",2)_$S(PSBHDR(1)["--":"",1:"/ ")_$P("^^^Future^Active^^Expired^DC'd^^^^^^^^^^",U,Y)_" " S PSBHDR(1)=$TR(PSBHDR(1),"-","")
.I $P(PSBFUTR,U,11) S PSBHDR(2)="Include Action(s)"_$S(PSBCFLG:" & Comments/Reasons",1:"")
.D PT^PSBOHDR(PSBXDFN,.PSBHDR)
Q
FTR ; Fter
D PTFTR^PSBOHDR()
S PSBPG="Page: "_PSBPGNUM_" of "_$S($O(PSBOUTP(""),-1)=0:1,1:$O(PSBOUTP(""),-1))
S PSBPGRM=PSBTAB8-($L(PSBPG))
W !,PSBRPNM," ",?(PSBPGRM-($L(PSBDTTM)+3)),PSBDTTM_" "_PSBPG
Q
PSBOCM1 ;BIRMINGHAM/TEJ-COVERSHEET MEDICATION OVERVIEW REPORT ;Mar 2004
+1 ;;3.0;BAR CODE MED ADMIN;**32,50**;Mar 2004;Build 78
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
BUILDLN ; Constr recs
+1 KILL J
SET J(0)=""
FOR PSBFLD=1:1:8
SET J=1
DO FORMDAT(PSBFLD)
SET J($ORDER(PSBRPLN(""),-1))=""
+2 ; Write administration info...
+3 IF 'PSBXFLG
QUIT
+4 SET J=($ORDER(J(""),-1)+1)
SET PSBRPLN(J)=PSBBLANK
SET J(J)=""
SET J=J+1
+5 SET (N,Y)=""
SET J=($ORDER(J(""),-1)+1)
+6 FOR
SET Y=$ORDER(PSBADM(PSBX2X,Y))
IF Y']""
QUIT
Begin DoDot:1
+7 FOR
SET N=$ORDER(PSBADM(PSBX2X,Y,N))
IF N']""
QUIT
Begin DoDot:2
+8 IF $DATA(PSBBID(PSBX2X,$PIECE(N,U,2)))
SET PSBDATA(2,0)="BAG ID: "_PSBBID(PSBX2X,$PIECE(N,U,2))
+9 SET $EXTRACT(PSBDATA(2,0),25)="ACTION BY: "_$PIECE(PSBADM(PSBX2X,Y,N),U,7)_" "_$$FMTDT^PSBOCE1($EXTRACT($PIECE(PSBADM(PSBX2X,Y,N),U,6),1,12))
+10 SET X=$PIECE(PSBADM(PSBX2X,Y,N),U,5)
SET $EXTRACT(PSBDATA(2,0),56)="ACTION: "_$SELECT(X="G":"GIVEN",X="R":"REFUSED",X="RM":"REMOVED",X="H":"HELD",X="S":"STOPPED",X="I":"INFUSING",X="C":"COMPLETED",X="M":"MISSING DOSE",X=" ":"*UNKNOWN*",1:" ")
+11 IF $DATA(PSBPRNR(PSBX2X))
SET $EXTRACT(PSBDATA(2,0),72)="PRN REASON: "_PSBPRNR(PSBX2X,$PIECE(N,U,2))
+12 IF $GET(PSBDATA(2,0))]" "
DO WRAPPER(1,132-1,PSBDATA(2,0))
KILL PSBDATA(2)
SET J=J+1
+13 NEW PSBEIECMT
SET PSBEIECMT=""
IF $DATA(PSBPRNEF(PSBX2X,$PIECE(N,U,2)))
IF $PIECE($GET(PSBRPT(.2)),U,8)=0
SET PSBEIECMT=$$PRNEFF^PSBO(PSBEIECMT,$PIECE(N,U,2))
+14 IF $DATA(PSBPRNEF(PSBX2X,$PIECE(N,U,2)))
SET PSBDATA(2,0)="PRN EFFECTIVENESS: "_PSBPRNEF(PSBX2X,$PIECE(N,U,2))_PSBEIECMT
+15 IF $GET(PSBDATA(2,0))]" "
DO WRAPPER(30,132-30,PSBDATA(2,0))
KILL PSBDATA(2)
SET J=J+1
+16 IF ('PSBCFLG)!('$DATA(PSBCMT(PSBX2X,$PIECE(N,U,2))))
SET PSBRPLN(J)=PSBBLANK
SET J(J)=""
SET J=J+1
QUIT
+17 SET X=""
FOR
SET X=$ORDER(PSBCMT(PSBX2X,$PIECE(N,U,2),X))
IF X']""
QUIT
Begin DoDot:3
+18 NEW PSBDAT
SET PSBDAT=""
FOR
SET PSBDAT=$ORDER(PSBCMT(PSBX2X,$PIECE(N,U,2),X,PSBDAT))
IF PSBDAT']""
QUIT
Begin DoDot:4
+19 SET PSBDATA(2,0)="COMMENT BY: "_$SELECT($PIECE(PSBCMT(PSBX2X,$PIECE(N,U,2),X,PSBDAT),U,5)]"":$PIECE(PSBCMT(PSBX2X,$PIECE(N,U,2),X,PSBDAT),U,5)_" "_$$FMTDT^PSBOCE1($EXTRACT($PIECE(PSBCMT(PSBX2X,$PIECE(N,U,2),X,PSB
DAT),U,6),1,12)),1:" n/a ")
+20 SET PSBDATA(2,0)=PSBDATA(2,0)_" COMMENT: "_$SELECT($PIECE(PSBCMT(PSBX2X,$PIECE(N,U,2),X,PSBDAT),U,2)]"":$PIECE(PSBCMT(PSBX2X,$PIECE(N,U,2),X,PSBDAT),U,2),1:" ")
+21 IF $GET(PSBDATA(2,0))]" "
DO WRAPPER(30,132-30,PSBDATA(2,0))
KILL PSBDATA(2)
SET J=J+1
End DoDot:4
End DoDot:3
+22 SET PSBRPLN(J)=PSBBLANK
SET J(J)=""
SET J=J+1
End DoDot:2
End DoDot:1
+23 QUIT
FORMDAT(FLD) ;
+1 KILL PSBVAL
+2 IF '$DATA(PSBDATA(1,FLD))
QUIT
+3 SET PSBVAL=PSBDATA(1,FLD)
+4 DO WRAPPER(@("PSBTAB"_(FLD-1))+1,((@("PSBTAB"_(FLD))-(@("PSBTAB"_(FLD-1))+1))),PSBVAL)
+5 IF FLD=4
SET J=$ORDER(J(""),-1)+1
SET PSBVAL=PSBDATA(1,4,0)
DO WRAPPER(@("PSBTAB"_(FLD-1))+1,((@("PSBTAB"_(FLD))-(@("PSBTAB"_(FLD-1))+1))),PSBVAL)
+6 QUIT
WRAPPER(X,Y,Z) ; Text WRAP
+1 NEW PSB
+2 IF ($LENGTH(Z)>0)
IF $FIND(Z,"""")>1
FOR
IF $FIND(Z,"""")'>1
QUIT
SET Z=$TRANSLATE(Z,"""","^")
+3 FOR
IF '$LENGTH(Z)
QUIT
Begin DoDot:1
+4 IF $LENGTH(Z)<Y
SET $EXTRACT(PSBRPLN(J),X)=Z
SET Z=""
Begin DoDot:2
+5 IF $LENGTH(PSBRPLN(J),"^")>1
FOR X=1:1:$LENGTH(PSBRPLN(J),"^")-1
SET $PIECE(PSBRPLN(J),"^",X)=$PIECE(PSBRPLN(J),"^",X)_""""
+6 SET PSBRPLN(J)=$TRANSLATE(PSBRPLN(J),"^","""")
End DoDot:2
QUIT
+7 FOR PSB=Y:-1:0
IF ($EXTRACT(Z,PSB)=" ")
QUIT
IF ($EXTRACT(Z,PSB)="-")
QUIT
+8 IF PSB<1
SET PSB=Y
+9 SET $EXTRACT(PSBRPLN(J),X)=$EXTRACT(Z,1,PSB)
+10 SET Z=$EXTRACT(Z,PSB+1,250)
+11 IF $LENGTH(PSBRPLN(J),"^")>1
FOR X=1:1:$LENGTH(PSBRPLN(J),"^")-1
SET $PIECE(PSBRPLN(J),"^",X)=$PIECE(PSBRPLN(J),"^",X)_""""
+12 SET PSBRPLN(J)=$TRANSLATE(PSBRPLN(J),"^","""")
+13 SET J=J+1
SET J(J)=""
End DoDot:1
+14 QUIT ""
CREATHDR ;
+1 KILL PSBHD1,PSBHD2
+2 IF IOM'<132
SET PSBHD1=$PIECE($TEXT(HD132A),"~",2)
SET PSBHD2=$PIECE($TEXT(HD132B),";",2)
SET PSBBLANK=$PIECE($TEXT(C132BLK),";",2)
+3 IF '$TEST
SET PSBHD1="THIS REPORT SUPPORTS >131 CHAR./LINE PRINT FORMATS ONLY"
QUIT
+4 ; reset tabs
+5 SET PSBTAB0=1
FOR PSBI=0:1:($LENGTH(PSBHD1,"|")-1)
IF PSBI>0
SET @("PSBTAB"_PSBI)=($FIND(PSBHD1,"|",@("PSBTAB"_(PSBI-1))+1))-1
+6 SET PSBPGNUM=1
+7 DO HDR
+8 QUIT
HD132A ;~VDL | Order |Type| Medication; Dosage, Route | Schedule | Next Action | Order Start | Order Stop |
+1 QUIT
HD132B ;Tab | Status | | | | | Date | Date |
+1 QUIT
C132BLK ;;
+1 QUIT
WRTRPT ; writ
+1 IF $ORDER(PSBOUTP(""),-1)<1
Begin DoDot:1
+2 XECUTE PSBOUTP($ORDER(PSBOUTP(""),-1),14)
+3 DO FTR
End DoDot:1
QUIT
+4 SET PSBPGNUM=1
+5 SET PSBZ=""
FOR
SET PSBZ=$ORDER(PSBOUTP(PSBZ))
IF PSBZ=""
QUIT
Begin DoDot:1
+6 IF PSBPGNUM'=PSBZ
DO FTR
SET PSBPGNUM=PSBZ
DO HDR
DO SUBHDR^PSBOCE
+7 SET PSBX2X=""
FOR
SET PSBX2X=$ORDER(PSBOUTP(PSBZ,PSBX2X))
IF PSBX2X=""
QUIT
Begin DoDot:2
+8 XECUTE PSBOUTP(PSBZ,PSBX2X)
End DoDot:2
End DoDot:1
+9 DO FTR
+10 KILL ^XTMP("PSBO",$JOB,"PSBLIST"),PSBOUTP
+11 QUIT
HDR ; Header
+1 IF $Y>1
WRITE @IOF
+2 IF $X>1
WRITE !
+3 SET PSBRPNM="BCMA COVERSHEET MEDICATION OVERVIEW REPORT"
+4 IF $PIECE(PSBRPT(.1),U,1)="P"
Begin DoDot:1
+5 SET PSBHDR(0)=PSBRPNM
+6 SET PSBHDR(1)="Order Status(es): --"
+7 FOR Y=4,5,7,8
IF $PIECE(PSBFUTR,U,Y)
SET $PIECE(PSBHDR(1),": ",2)=$PIECE(PSBHDR(1),": ",2)_$SELECT(PSBHDR(1)["--":"",1:"/ ")_$PIECE("^^^Future^Active^^Expired^DC'd^^^^^^^^^^",U,Y)_" "
SET PSBHDR(1)=$TRANSLATE(PSBHDR(1),"-","")
+8 IF $PIECE(PSBFUTR,U,11)
SET PSBHDR(2)="Include Action(s)"_$SELECT(PSBCFLG:" & Comments/Reasons",1:"")
+9 DO PT^PSBOHDR(PSBXDFN,.PSBHDR)
End DoDot:1
+10 QUIT
FTR ; Fter
+1 DO PTFTR^PSBOHDR()
+2 SET PSBPG="Page: "_PSBPGNUM_" of "_$SELECT($ORDER(PSBOUTP(""),-1)=0:1,1:$ORDER(PSBOUTP(""),-1))
+3 SET PSBPGRM=PSBTAB8-($LENGTH(PSBPG))
+4 WRITE !,PSBRPNM," ",?(PSBPGRM-($LENGTH(PSBDTTM)+3)),PSBDTTM_" "_PSBPG
+5 QUIT
