PSBOIV1 ;BIRMINGHAM/TEJ-IV BAG STATUS 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.
;
FORMDAT(FLD) ;
K PSBVAL
S PSBVAL=PSBDATA(FLD)
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 INX=1:1:$L(PSBRPLN(J),"^")-1 S $P(PSBRPLN(J),"^",INX)=$P(PSBRPLN(J),"^",INX)_""""
..S PSBRPLN(J)=$TR(PSBRPLN(J),"^","""")
..S J(J)="",J=J+1
.F PSB=Y:-1:0 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 INX=1:1:$L(PSBRPLN(J),"^")-1 S $P(PSBRPLN(J),"^",INX)=$P(PSBRPLN(J),"^",INX)_""""
.S PSBRPLN(J)=$TR(PSBRPLN(J),"^","""")
.S J(J)="",J=J+1
Q 0
FMTDT(Y) ;
N X S X=$E(Y,4,5) X ^DD("DD") S Y=$TR(Y," ,:","//") S $P(Y,"/")=X
Q Y
SUBHDR ;
N PSBAL S PSBAL=$O(PSBHDR("ALERGY",""),-1) S PSBAL=$S((PSBAL/12)>(PSBAL\12):(PSBAL\12)+1,1:(PSBAL\12))
N PSBRE S PSBRE=$O(PSBHDR("REAC",""),-1) S PSBRE=$S((PSBRE/12)>(PSBRE\12):(PSBRE\12)+1,1:(PSBRE\12))
S PSBLNTOT=$O(PSBHDR(""),-1)+9+PSBAL+PSBRE+1
W !,$G(PSBHD1,"") S PSBLNTOT=PSBLNTOT+1
W !,$G(PSBHD2,"") S PSBLNTOT=PSBLNTOT+1
W !,$TR($J("",PSBTAB8)," ","="),! S PSBLNTOT=PSBLNTOT+2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOIV1 1480 printed Nov 22, 2024@16:50:49 Page 2
PSBOIV1 ;BIRMINGHAM/TEJ-IV BAG STATUS 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 ;
FORMDAT(FLD) ;
+1 KILL PSBVAL
+2 SET PSBVAL=PSBDATA(FLD)
+3 DO WRAPPER(@("PSBTAB"_(FLD-1))+1,((@("PSBTAB"_(FLD))-(@("PSBTAB"_(FLD-1))+1))),PSBVAL)
+4 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 INX=1:1:$LENGTH(PSBRPLN(J),"^")-1
SET $PIECE(PSBRPLN(J),"^",INX)=$PIECE(PSBRPLN(J),"^",INX)_""""
+6 SET PSBRPLN(J)=$TRANSLATE(PSBRPLN(J),"^","""")
+7 SET J(J)=""
SET J=J+1
End DoDot:2
QUIT
+8 FOR PSB=Y:-1:0
if $EXTRACT(Z,PSB)=" "
QUIT
+9 if PSB<1
SET PSB=Y
+10 SET $EXTRACT(PSBRPLN(J),X)=$EXTRACT(Z,1,PSB)
+11 SET Z=$EXTRACT(Z,PSB+1,250)
+12 IF $LENGTH(PSBRPLN(J),"^")>1
FOR INX=1:1:$LENGTH(PSBRPLN(J),"^")-1
SET $PIECE(PSBRPLN(J),"^",INX)=$PIECE(PSBRPLN(J),"^",INX)_""""
+13 SET PSBRPLN(J)=$TRANSLATE(PSBRPLN(J),"^","""")
+14 SET J(J)=""
SET J=J+1
End DoDot:1
+15 QUIT 0
FMTDT(Y) ;
+1 NEW X
SET X=$EXTRACT(Y,4,5)
XECUTE ^DD("DD")
SET Y=$TRANSLATE(Y," ,:","//")
SET $PIECE(Y,"/")=X
+2 QUIT Y
SUBHDR ;
+1 NEW PSBAL
SET PSBAL=$ORDER(PSBHDR("ALERGY",""),-1)
SET PSBAL=$SELECT((PSBAL/12)>(PSBAL\12):(PSBAL\12)+1,1:(PSBAL\12))
+2 NEW PSBRE
SET PSBRE=$ORDER(PSBHDR("REAC",""),-1)
SET PSBRE=$SELECT((PSBRE/12)>(PSBRE\12):(PSBRE\12)+1,1:(PSBRE\12))
+3 SET PSBLNTOT=$ORDER(PSBHDR(""),-1)+9+PSBAL+PSBRE+1
+4 WRITE !,$GET(PSBHD1,"")
SET PSBLNTOT=PSBLNTOT+1
+5 WRITE !,$GET(PSBHD2,"")
SET PSBLNTOT=PSBLNTOT+1
+6 WRITE !,$TRANSLATE($JUSTIFY("",PSBTAB8)," ","="),!
SET PSBLNTOT=PSBLNTOT+2
+7 QUIT
