PSBOIV1.m

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 

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