- PSBOCM1 ;BIRMINGHAM/TEJ-COVERSHEET MEDICATION OVERVIEW REPORT ;9/18/12 1:53am
- ;;3.0;BAR CODE MED ADMIN;**32,50,70**;Mar 2004;Build 101
- ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
- ;
- ;*70 - add new header line for clinic search list
- ;
- 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:"")
- .S:$G(PSBSRCHL)]"" PSBHDR(3)="",PSBHDR(4)=PSBSRCHL ;*70
- .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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOCM1 5039 printed Feb 18, 2025@23:06:51 Page 2
- PSBOCM1 ;BIRMINGHAM/TEJ-COVERSHEET MEDICATION OVERVIEW REPORT ;9/18/12 1:53am
- +1 ;;3.0;BAR CODE MED ADMIN;**32,50,70**;Mar 2004;Build 101
- +2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
- +3 ;
- +4 ;*70 - add new header line for clinic search list
- +5 ;
- 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 ;*70
- if $GET(PSBSRCHL)]""
- SET PSBHDR(3)=""
- SET PSBHDR(4)=PSBSRCHL
- +10 DO PT^PSBOHDR(PSBXDFN,.PSBHDR)
- End DoDot:1
- +11 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