PSBOCI1 ;BIRMINGHAM/TEJ-COVERSHEET IV OVERVIEW REPORT ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**32**;Mar 2004;Build 32
;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:7 S J=1 D FORMDAT^PSBOCE1(PSBFLD) S J($O(PSBRPLN(""),-1))=""
; Write administration info...
Q:'PSBXFLG
; Get Actions
K PSBXDTL S (PSBXDTL,N,Y)="",J=($O(J(""),-1)+1)
D BAGDTL^PSBRPC2(.PSBXDTL,XI,PSBX2X)
I $D(PSBXDTL(1)) I +$P(PSBXDTL(1),U)=-1 S PSBRPLN(J)=PSBBLANK,J(J)="",J=J+1 Q
S J=($O(J(""),-1)+1),PSBRPLN(J)=PSBBLANK,J(J)="",J=J+1
F Y=1:1:PSBXDTL(0) S N=PSBXDTL(Y) D
.Q:('PSBCFLG)&($P(N,U,3)']"")
.S $E(PSBDATA(2,0),25)="BY: "_$P(N,U,2)_" "_$$FMTDT^PSBOCE1($E($P(N,U),1,12))
.S $E(PSBDATA(2,0),49)="ACTION: "_$P(N,U,3)
.I $G(PSBDATA(2,0))]" " D WRAPPER^PSBOCE1(1,132-1,PSBDATA(2,0)) K PSBDATA(2) S J=J+1
.M PSBLGD("INITIALS")=PSBLGD(PSBX2X,"INITIALS")
.Q:('PSBCFLG)!($P(N,U,4)']"")
.S PSBDATA(2,0)=$G(PSBDATA(2,0),"")_" COMMENT: "_$P(N,U,4)
.I $G(PSBDATA(2,0))]" " D WRAPPER^PSBOCE1(49,132-49,PSBDATA(2,0)) K PSBDATA(2) S J=J+1
S PSBRPLN(J)=PSBBLANK,J(J)="",J=J+1
Q
PTFTR ;Patient Page footer
I (IOSL<100) F Q:$Y>(IOSL-7) W !
W !,$TR($J("",IOM)," ","=")
S X="Ward: "_PSBHDR("WARD")_" Room-Bed: "_PSBHDR("ROOM")
W !,PSBHDR("NAME"),?(IOM-11\2),PSBHDR("SSN"),?(IOM-$L(X)),X
S PSBPG="Page: "_PSBPGNUM_" of "_$S($O(PSBOUTP(""),-1)=0:1,1:$O(PSBOUTP(""),-1))
S PSBPGRM=PSBTAB7-($L(PSBPG))
W !,PSBRPNM," ",?(PSBPGRM-($L(PSBDTTM)+3)),PSBDTTM_" "_PSBPG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOCI1 1595 printed Dec 13, 2024@01:40:26 Page 2
PSBOCI1 ;BIRMINGHAM/TEJ-COVERSHEET IV OVERVIEW REPORT ;Mar 2004
+1 ;;3.0;BAR CODE MED ADMIN;**32**;Mar 2004;Build 32
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ;
BUILDLN ; Constr recs
+1 KILL J
SET J(0)=""
FOR PSBFLD=1:1:7
SET J=1
DO FORMDAT^PSBOCE1(PSBFLD)
SET J($ORDER(PSBRPLN(""),-1))=""
+2 ; Write administration info...
+3 if 'PSBXFLG
QUIT
+4 ; Get Actions
+5 KILL PSBXDTL
SET (PSBXDTL,N,Y)=""
SET J=($ORDER(J(""),-1)+1)
+6 DO BAGDTL^PSBRPC2(.PSBXDTL,XI,PSBX2X)
+7 IF $DATA(PSBXDTL(1))
IF +$PIECE(PSBXDTL(1),U)=-1
SET PSBRPLN(J)=PSBBLANK
SET J(J)=""
SET J=J+1
QUIT
+8 SET J=($ORDER(J(""),-1)+1)
SET PSBRPLN(J)=PSBBLANK
SET J(J)=""
SET J=J+1
+9 FOR Y=1:1:PSBXDTL(0)
SET N=PSBXDTL(Y)
Begin DoDot:1
+10 if ('PSBCFLG)&($PIECE(N,U,3)']"")
QUIT
+11 SET $EXTRACT(PSBDATA(2,0),25)="BY: "_$PIECE(N,U,2)_" "_$$FMTDT^PSBOCE1($EXTRACT($PIECE(N,U),1,12))
+12 SET $EXTRACT(PSBDATA(2,0),49)="ACTION: "_$PIECE(N,U,3)
+13 IF $GET(PSBDATA(2,0))]" "
DO WRAPPER^PSBOCE1(1,132-1,PSBDATA(2,0))
KILL PSBDATA(2)
SET J=J+1
+14 MERGE PSBLGD("INITIALS")=PSBLGD(PSBX2X,"INITIALS")
+15 if ('PSBCFLG)!($PIECE(N,U,4)']"")
QUIT
+16 SET PSBDATA(2,0)=$GET(PSBDATA(2,0),"")_" COMMENT: "_$PIECE(N,U,4)
+17 IF $GET(PSBDATA(2,0))]" "
DO WRAPPER^PSBOCE1(49,132-49,PSBDATA(2,0))
KILL PSBDATA(2)
SET J=J+1
End DoDot:1
+18 SET PSBRPLN(J)=PSBBLANK
SET J(J)=""
SET J=J+1
+19 QUIT
PTFTR ;Patient Page footer
+1 IF (IOSL<100)
FOR
if $Y>(IOSL-7)
QUIT
WRITE !
+2 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","=")
+3 SET X="Ward: "_PSBHDR("WARD")_" Room-Bed: "_PSBHDR("ROOM")
+4 WRITE !,PSBHDR("NAME"),?(IOM-11\2),PSBHDR("SSN"),?(IOM-$LENGTH(X)),X
+5 SET PSBPG="Page: "_PSBPGNUM_" of "_$SELECT($ORDER(PSBOUTP(""),-1)=0:1,1:$ORDER(PSBOUTP(""),-1))
+6 SET PSBPGRM=PSBTAB7-($LENGTH(PSBPG))
+7 WRITE !,PSBRPNM," ",?(PSBPGRM-($LENGTH(PSBDTTM)+3)),PSBDTTM_" "_PSBPG
+8 QUIT
