- 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 Feb 18, 2025@23:06:49 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