PSBOCP1.m

PSBOCP1 ;BIRMINGHAM/TEJ-COVERSHEET PRN 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.

 ;

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

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 |    Status   |Type|      Medication; Dosage, Route      |   Last Given  |      Since    |    Order Start   |    Order Stop   |

 Q

HD132B ; Tab |             |    |                                     |               |   Last Given  |    Date          |    Date         |

 Q

C132BLK ;;     |             |    |                                     |               |               |                  |                 |

 Q

HDR ;  Header

 W:$Y>1 @IOF

 W:$X>1 !

 S PSBRPNM="BCMA COVERSHEET PRN 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:"")

 .D PT^PSBOHDR(PSBXDFN,.PSBHDR)

 Q

FTR ;  Fter

 S PSBPG="Page: "_PSBPGNUM_" of "_$S($O(PSBOUTP(""),-1)=0:1,1:$O(PSBOUTP(""),-1))

 S PSBPGRM=PSBTAB8-($L(PSBPG))

 D PTFTR^PSBOHDR()

 W !,PSBRPNM,"     ",?(PSBPGRM-($L(PSBDTTM)+3)),PSBDTTM_"  "_PSBPG

 Q

PSBOCP1   ;BIRMINGHAM/TEJ-COVERSHEET PRN 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       ;

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 

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 |    Status   |Type|      Medication; Dosage, Route      |   Last Given  |      Since    |    Order Start   |    Order Stop   |

 +1        QUIT 

HD132B    ; Tab |             |    |                                     |               |   Last Given  |    Date          |    Date         |

 +1        QUIT 

C132BLK   ;;     |             |    |                                     |               |               |                  |                 |

 +1        QUIT 

HDR       ;  Header

 +1        IF $Y>1

               WRITE @IOF

 +2        IF $X>1

               WRITE !

 +3        SET PSBRPNM="BCMA COVERSHEET PRN 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                DO PT^PSBOHDR(PSBXDFN,.PSBHDR)

               End DoDot:1

 +10       QUIT 

FTR       ;  Fter

 +1        SET PSBPG="Page: "_PSBPGNUM_" of "_$SELECT($ORDER(PSBOUTP(""),-1)=0:1,1:$ORDER(PSBOUTP(""),-1))

 +2        SET PSBPGRM=PSBTAB8-($LENGTH(PSBPG))

 +3        DO PTFTR^PSBOHDR()

 +4        WRITE !,PSBRPNM,"     ",?(PSBPGRM-($LENGTH(PSBDTTM)+3)),PSBDTTM_"  "_PSBPG

 +5        QUIT