BCHRLP.m

BCHRLP ; IHS/CMI/LAB - PRINT CHR RECORD REPORT ; 

 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27

 ;

 ;IHS/CMI/LAB - tmp to xtmp

 ;CMI/TUCSON/LAB - modified 2 lines to replace a reference to the 8th piece to a reference to 4th piece 6/22/98 patch 5

START ;EP - Set up header line, dash line

 S X=0,BCHHEAD="" F  S X=$O(^BCHTRPT(BCHRPT,12,X)) Q:X'=+X  S BCHHDR=$P(^BCHSORT($P(^BCHTRPT(BCHRPT,12,X,0),U),0),U,6),BCHLENG=$P(^BCHTRPT(BCHRPT,12,X,0),U,2),BCHHDR=$E(BCHHDR,1,BCHLENG) D

 .S J=$L(BCHHDR),BCHHEAD=BCHHEAD_BCHHDR,K=$P(^BCHTRPT(BCHRPT,12,X,0),U,2)+1 F I=J:1:K S BCHHEAD=BCHHEAD_" "

 .Q

 S BCHDASH="",$P(BCHDASH,"-",BCHTCW)="-"

 D COVPAGE^BCHRLP1 ;print cover page - note: if user ^'s out of cover page, processing continues

PROC ;process printing of report

 I BCHCTYP="T" G DONE ;--- if displaying only total, that was done in the cover page - go to done

 S BCHPG=0 I '$D(^XTMP("BCHRL",BCHJOB,BCHBTH)) G DONE

 S (BCHSRTV,BCHFRST)="" K BCHQUIT

 F  S BCHSRTV=$O(^XTMP("BCHRL",BCHJOB,BCHBTH,"DATA HITS",BCHSRTV)) Q:BCHSRTV=""!($D(BCHQUIT))  D V

 G:$D(BCHQUIT) DONE

 I $Y>(IOSL-4) D HEAD G:$D(BCHQUIT) DONE

 I $D(BCHRCNT),BCHPTVS="V" W !!!,"Total ",$S(BCHPTVS="P":"Patients",1:"Records"),":  ",BCHRCNT

 ;W !!,"Total Patients:  ",BCHPTCT

DONE ;

 D DONE^BCHUTIL1

 Q

V ;GETS DATA HITS

 S BCHSCNT=0

 ;get readable sort value

 S BCHSRTR="",BCHR=$O(^XTMP("BCHRL",BCHJOB,BCHBTH,"DATA HITS",BCHSRTV,"")) I BCHR]"" S BCHCRIT=BCHSORT D

 .I BCHPTVS="V" S BCHR0=^BCHR(BCHR,0),DFN=$P(BCHR0,U,4) X:$D(^BCHSORT(BCHSORT,3)) ^(3) S BCHSRTR=BCHPRNT ;CMI/TUCSON/LAB - changed ,U,8 to ,U,4 PATCH 5 6/22/98

 .I BCHPTVS="P" S DFN=BCHR X:$D(^BCHSORT(BCHSORT,3)) ^(3) S BCHSRTR=BCHPRNT

 I $G(BCHSPAG)!($D(BCHFRST)) D HEAD Q:$D(BCHQUIT)

 K BCHFRST

 S BCHR=0 F  S BCHR=$O(^XTMP("BCHRL",BCHJOB,BCHBTH,"DATA HITS",BCHSRTV,BCHR)) Q:BCHR'=+BCHR!($D(BCHQUIT))  D

 .I BCHPTVS="V" S BCHR0=^BCHR(BCHR,0),DFN=$P(BCHR0,U,4) D PRINT Q  ;CMI/TUCSON/LAB - changed 8 to 4 patch 5 6/22/98

 .S DFN=BCHR D PRINT

 .Q

 Q:$D(BCHQUIT)

 I $Y>(IOSL-3) D HEAD Q:$D(BCHQUIT)

 W:$G(BCHSPAG) !!,"SUB-TOTAL for ",BCHSORV," ",BCHSRTR,":  ",BCHSCNT

 W:BCHCTYP="S" !?10,$E(BCHSRTR,1,30),?45,$J(BCHSCNT,8)

 Q

PRINT ;

 S BCHSCNT=BCHSCNT+1 Q:BCHCTYP="S"

 K ^XTMP("BCHLINE",$J) S ^XTMP("BCHLINE",$J,1)=""

 I $Y>(IOSL-5) D HEAD Q:$D(BCHQUIT)

 S BCHI=0 F  S BCHI=$O(^BCHTRPT(BCHRPT,12,BCHI)) Q:BCHI'=+BCHI!($D(BCHQUIT))  S BCHCRIT=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U) D

 .I '$P(^BCHSORT(BCHCRIT,0),U,8) D SINGLE Q

 .D MULT

 .Q

 S BCHX=0 F  S BCHX=$O(^XTMP("BCHLINE",$J,BCHX)) Q:BCHX'=+BCHX!($D(BCHQUIT))  D

 .I $Y>(IOSL-4) D HEAD Q:$D(BCHQUIT)

 .W !,^XTMP("BCHLINE",$J,BCHX)

 Q

SINGLE ;process single valued item

 K BCHPRNT

 S BCHX=0

 X:$D(^BCHSORT(BCHCRIT,3)) ^(3) I $G(BCHPRNT)="" S BCHPRNT="--"

 S BCHLENG=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2),BCHPRNT=$E($G(BCHPRNT),1,BCHLENG) D

 .S J=$L(BCHPRNT),^XTMP("BCHLINE",$J,1)=^XTMP("BCHLINE",$J,1)_BCHPRNT,K=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1 F I=J:1:K S ^XTMP("BCHLINE",$J,1)=^XTMP("BCHLINE",$J,1)_" "

 .S X=1 F  S X=$O(^XTMP("BCHLINE",$J,X)) Q:X'=+X  I $L(^XTMP("BCHLINE",$J,X))<$L(^XTMP("BCHLINE",$J,1)) S K=$L(^XTMP("BCHLINE",$J,X))+1,J=$L(^XTMP("BCHLINE",$J,1)) F I=K:1:J S ^XTMP("BCHLINE",$J,X)=^XTMP("BCHLINE",$J,X)_" "

 Q

MULT ;

 K BCHPRNT,BCHPRNM S (BCHX,BCHPCNT)=0

 X:$D(^BCHSORT(BCHCRIT,3)) ^(3)

 I '$D(BCHPRNM) S BCHPRNT="--" D

 .S BCHLENG=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2),BCHPRNT=$E(BCHPRNT,1,BCHLENG) D

 ..S J=$L(BCHPRNT),^XTMP("BCHLINE",$J,1)=^XTMP("BCHLINE",$J,1)_BCHPRNT,K=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1 F I=J:1:K S ^XTMP("BCHLINE",$J,1)=^XTMP("BCHLINE",$J,1)_" "

 S X=0 F  S X=$O(BCHPRNM(X)) Q:X'=+X  D

 .I X=1 D  Q

 ..S BCHLENG=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2),BCHPRNT=$E(BCHPRNM(1),1,BCHLENG) D

 ...S J=$L(BCHPRNT),^XTMP("BCHLINE",$J,1)=^XTMP("BCHLINE",$J,1)_BCHPRNT,K=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1 F I=J:1:K S ^XTMP("BCHLINE",$J,1)=^XTMP("BCHLINE",$J,1)_" "

 .S BCHLENG=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2),BCHPRNT=$E(BCHPRNM(X),1,BCHLENG) D

 ..I '$D(^XTMP("BCHLINE",$J,X)) S ^XTMP("BCHLINE",$J,X)="",K=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1,$P(^XTMP("BCHLINE",$J,X)," ",($L(^XTMP("BCHLINE",$J,1))-K))=""

 ..S J=$L(BCHPRNT),^XTMP("BCHLINE",$J,X)=^XTMP("BCHLINE",$J,X)_BCHPRNT,K=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1 F I=J:1:K S ^XTMP("BCHLINE",$J,X)=^XTMP("BCHLINE",$J,X)_" "

 S X=1 F  S X=$O(^XTMP("BCHLINE",$J,X)) Q:X'=+X  I $L(^XTMP("BCHLINE",$J,X))<$L(^XTMP("BCHLINE",$J,1)) S K=$L(^XTMP("BCHLINE",$J,X))+1,J=$L(^XTMP("BCHLINE",$J,1)) F I=K:1:J S ^XTMP("BCHLINE",$J,X)=^XTMP("BCHLINE",$J,X)_" "

 Q

DIQ ;

 K BCHPRNT,BCHFILE,BCHFIEL

 S BCHFILE=$P($P(^BCHSORT(BCHCRIT,0),U,4),","),BCHFIEL=$P($P(^(0),U,4),",",2)

 S DIQ(0)="EN",DIQ="BCHPRNT(",DIC=BCHFILE,DR=BCHFIEL D EN^DIQ1 K DIC,DR,DIQ

 I '$D(BCHPRNT(BCHFILE,DA,BCHFIEL,"E")) S BCHPRNT(BCHFILE,DA,BCHFIEL,"E")="--"

 S BCHPRNT=BCHPRNT(BCHFILE,DA,BCHFIEL,"E")

 Q

HEAD ;ENTRY POINT

 D HEAD^BCHRLP2

 Q

BCHRLP    ; IHS/CMI/LAB - PRINT CHR RECORD REPORT ; 

 +1       ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27

 +2       ;

 +3       ;IHS/CMI/LAB - tmp to xtmp

 +4       ;CMI/TUCSON/LAB - modified 2 lines to replace a reference to the 8th piece to a reference to 4th piece 6/22/98 patch 5

START     ;EP - Set up header line, dash line

 +1        SET X=0

           SET BCHHEAD=""

           FOR 

               SET X=$ORDER(^BCHTRPT(BCHRPT,12,X))

               IF X'=+X

                   QUIT 

               SET BCHHDR=$PIECE(^BCHSORT($PIECE(^BCHTRPT(BCHRPT,12,X,0),U),0),U,6)

               SET BCHLENG=$PIECE(^BCHTRPT(BCHRPT,12,X,0),U,2)

               SET BCHHDR=$EXTRACT(BCHHDR,1,BCHLENG)

               Begin DoDot:1

 +2                SET J=$LENGTH(BCHHDR)

                   SET BCHHEAD=BCHHEAD_BCHHDR

                   SET K=$PIECE(^BCHTRPT(BCHRPT,12,X,0),U,2)+1

                   FOR I=J:1:K

                       SET BCHHEAD=BCHHEAD_" "

 +3                QUIT 

               End DoDot:1

 +4        SET BCHDASH=""

           SET $PIECE(BCHDASH,"-",BCHTCW)="-"

 +5       ;print cover page - note: if user ^'s out of cover page, processing continues

           DO COVPAGE^BCHRLP1

PROC      ;process printing of report

 +1       ;--- if displaying only total, that was done in the cover page - go to done

           IF BCHCTYP="T"

               GOTO DONE

 +2        SET BCHPG=0

           IF '$DATA(^XTMP("BCHRL",BCHJOB,BCHBTH))

               GOTO DONE

 +3        SET (BCHSRTV,BCHFRST)=""

           KILL BCHQUIT

 +4        FOR 

               SET BCHSRTV=$ORDER(^XTMP("BCHRL",BCHJOB,BCHBTH,"DATA HITS",BCHSRTV))

               IF BCHSRTV=""!($DATA(BCHQUIT))

                   QUIT 

               DO V

 +5        IF $DATA(BCHQUIT)

               GOTO DONE

 +6        IF $Y>(IOSL-4)

               DO HEAD

               IF $DATA(BCHQUIT)

                   GOTO DONE

 +7        IF $DATA(BCHRCNT)

               IF BCHPTVS="V"

                   WRITE !!!,"Total ",$SELECT(BCHPTVS="P":"Patients",1:"Records"),":  ",BCHRCNT

 +8       ;W !!,"Total Patients:  ",BCHPTCT

DONE      ;

 +1        DO DONE^BCHUTIL1

 +2        QUIT 

V         ;GETS DATA HITS

 +1        SET BCHSCNT=0

 +2       ;get readable sort value

 +3        SET BCHSRTR=""

           SET BCHR=$ORDER(^XTMP("BCHRL",BCHJOB,BCHBTH,"DATA HITS",BCHSRTV,""))

           IF BCHR]""

               SET BCHCRIT=BCHSORT

               Begin DoDot:1

 +4       ;CMI/TUCSON/LAB - changed ,U,8 to ,U,4 PATCH 5 6/22/98

                   IF BCHPTVS="V"

                       SET BCHR0=^BCHR(BCHR,0)

                       SET DFN=$PIECE(BCHR0,U,4)

                       IF $DATA(^BCHSORT(BCHSORT,3))

                           XECUTE ^(3)

                       SET BCHSRTR=BCHPRNT

 +5                IF BCHPTVS="P"

                       SET DFN=BCHR

                       IF $DATA(^BCHSORT(BCHSORT,3))

                           XECUTE ^(3)

                       SET BCHSRTR=BCHPRNT

               End DoDot:1

 +6        IF $GET(BCHSPAG)!($DATA(BCHFRST))

               DO HEAD

               IF $DATA(BCHQUIT)

                   QUIT 

 +7        KILL BCHFRST

 +8        SET BCHR=0

           FOR 

               SET BCHR=$ORDER(^XTMP("BCHRL",BCHJOB,BCHBTH,"DATA HITS",BCHSRTV,BCHR))

               IF BCHR'=+BCHR!($DATA(BCHQUIT))

                   QUIT 

               Begin DoDot:1

 +9       ;CMI/TUCSON/LAB - changed 8 to 4 patch 5 6/22/98

                   IF BCHPTVS="V"

                       SET BCHR0=^BCHR(BCHR,0)

                       SET DFN=$PIECE(BCHR0,U,4)

                       DO PRINT

                       QUIT 

 +10               SET DFN=BCHR

                   DO PRINT

 +11               QUIT 

               End DoDot:1

 +12       IF $DATA(BCHQUIT)

               QUIT 

 +13       IF $Y>(IOSL-3)

               DO HEAD

               IF $DATA(BCHQUIT)

                   QUIT 

 +14       IF $GET(BCHSPAG)

               WRITE !!,"SUB-TOTAL for ",BCHSORV," ",BCHSRTR,":  ",BCHSCNT

 +15       IF BCHCTYP="S"

               WRITE !?10,$EXTRACT(BCHSRTR,1,30),?45,$JUSTIFY(BCHSCNT,8)

 +16       QUIT 

PRINT     ;

 +1        SET BCHSCNT=BCHSCNT+1

           IF BCHCTYP="S"

               QUIT 

 +2        KILL ^XTMP("BCHLINE",$JOB)

           SET ^XTMP("BCHLINE",$JOB,1)=""

 +3        IF $Y>(IOSL-5)

               DO HEAD

               IF $DATA(BCHQUIT)

                   QUIT 

 +4        SET BCHI=0

           FOR 

               SET BCHI=$ORDER(^BCHTRPT(BCHRPT,12,BCHI))

               IF BCHI'=+BCHI!($DATA(BCHQUIT))

                   QUIT 

               SET BCHCRIT=$PIECE(^BCHTRPT(BCHRPT,12,BCHI,0),U)

               Begin DoDot:1

 +5                IF '$PIECE(^BCHSORT(BCHCRIT,0),U,8)

                       DO SINGLE

                       QUIT 

 +6                DO MULT

 +7                QUIT 

               End DoDot:1

 +8        SET BCHX=0

           FOR 

               SET BCHX=$ORDER(^XTMP("BCHLINE",$JOB,BCHX))

               IF BCHX'=+BCHX!($DATA(BCHQUIT))

                   QUIT 

               Begin DoDot:1

 +9                IF $Y>(IOSL-4)

                       DO HEAD

                       IF $DATA(BCHQUIT)

                           QUIT 

 +10               WRITE !,^XTMP("BCHLINE",$JOB,BCHX)

               End DoDot:1

 +11       QUIT 

SINGLE    ;process single valued item

 +1        KILL BCHPRNT

 +2        SET BCHX=0

 +3        IF $DATA(^BCHSORT(BCHCRIT,3))

               XECUTE ^(3)

           IF $GET(BCHPRNT)=""

               SET BCHPRNT="--"

 +4        SET BCHLENG=$PIECE(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)

           SET BCHPRNT=$EXTRACT($GET(BCHPRNT),1,BCHLENG)

           Begin DoDot:1

 +5            SET J=$LENGTH(BCHPRNT)

               SET ^XTMP("BCHLINE",$JOB,1)=^XTMP("BCHLINE",$JOB,1)_BCHPRNT

               SET K=$PIECE(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1

               FOR I=J:1:K

                   SET ^XTMP("BCHLINE",$JOB,1)=^XTMP("BCHLINE",$JOB,1)_" "

 +6            SET X=1

               FOR 

                   SET X=$ORDER(^XTMP("BCHLINE",$JOB,X))

                   IF X'=+X

                       QUIT 

                   IF $LENGTH(^XTMP("BCHLINE",$JOB,X))<$LENGTH(^XTMP("BCHLINE",$JOB,1))

                       SET K=$LENGTH(^XTMP("BCHLINE",$JOB,X))+1

                       SET J=$LENGTH(^XTMP("BCHLINE",$JOB,1))

                       FOR I=K:1:J

                           SET ^XTMP("BCHLINE",$JOB,X)=^XTMP("BCHLINE",$JOB,X)_" "

           End DoDot:1

 +7        QUIT 

MULT      ;

 +1        KILL BCHPRNT,BCHPRNM

           SET (BCHX,BCHPCNT)=0

 +2        IF $DATA(^BCHSORT(BCHCRIT,3))

               XECUTE ^(3)

 +3        IF '$DATA(BCHPRNM)

               SET BCHPRNT="--"

               Begin DoDot:1

 +4                SET BCHLENG=$PIECE(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)

                   SET BCHPRNT=$EXTRACT(BCHPRNT,1,BCHLENG)

                   Begin DoDot:2

 +5                    SET J=$LENGTH(BCHPRNT)

                       SET ^XTMP("BCHLINE",$JOB,1)=^XTMP("BCHLINE",$JOB,1)_BCHPRNT

                       SET K=$PIECE(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1

                       FOR I=J:1:K

                           SET ^XTMP("BCHLINE",$JOB,1)=^XTMP("BCHLINE",$JOB,1)_" "

                   End DoDot:2

               End DoDot:1

 +6        SET X=0

           FOR 

               SET X=$ORDER(BCHPRNM(X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +7                IF X=1

                       Begin DoDot:2

 +8                        SET BCHLENG=$PIECE(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)

                           SET BCHPRNT=$EXTRACT(BCHPRNM(1),1,BCHLENG)

                           Begin DoDot:3

 +9                            SET J=$LENGTH(BCHPRNT)

                               SET ^XTMP("BCHLINE",$JOB,1)=^XTMP("BCHLINE",$JOB,1)_BCHPRNT

                               SET K=$PIECE(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1

                               FOR I=J:1:K

                                   SET ^XTMP("BCHLINE",$JOB,1)=^XTMP("BCHLINE",$JOB,1)_" "

                           End DoDot:3

                       End DoDot:2

                       QUIT 

 +10               SET BCHLENG=$PIECE(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)

                   SET BCHPRNT=$EXTRACT(BCHPRNM(X),1,BCHLENG)

                   Begin DoDot:2

 +11                   IF '$DATA(^XTMP("BCHLINE",$JOB,X))

                           SET ^XTMP("BCHLINE",$JOB,X)=""

                           SET K=$PIECE(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1

                           SET $PIECE(^XTMP("BCHLINE",$JOB,X)," ",($LENGTH(^XTMP("BCHLINE",$JOB,1))-K))=""

 +12                   SET J=$LENGTH(BCHPRNT)

                       SET ^XTMP("BCHLINE",$JOB,X)=^XTMP("BCHLINE",$JOB,X)_BCHPRNT

                       SET K=$PIECE(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)+1

                       FOR I=J:1:K

                           SET ^XTMP("BCHLINE",$JOB,X)=^XTMP("BCHLINE",$JOB,X)_" "

                   End DoDot:2

               End DoDot:1

 +13       SET X=1

           FOR 

               SET X=$ORDER(^XTMP("BCHLINE",$JOB,X))

               IF X'=+X

                   QUIT 

               IF $LENGTH(^XTMP("BCHLINE",$JOB,X))<$LENGTH(^XTMP("BCHLINE",$JOB,1))

                   SET K=$LENGTH(^XTMP("BCHLINE",$JOB,X))+1

                   SET J=$LENGTH(^XTMP("BCHLINE",$JOB,1))

                   FOR I=K:1:J

                       SET ^XTMP("BCHLINE",$JOB,X)=^XTMP("BCHLINE",$JOB,X)_" "

 +14       QUIT 

DIQ       ;

 +1        KILL BCHPRNT,BCHFILE,BCHFIEL

 +2        SET BCHFILE=$PIECE($PIECE(^BCHSORT(BCHCRIT,0),U,4),",")

           SET BCHFIEL=$PIECE($PIECE(^(0),U,4),",",2)

 +3        SET DIQ(0)="EN"

           SET DIQ="BCHPRNT("

           SET DIC=BCHFILE

           SET DR=BCHFIEL

           DO EN^DIQ1

           KILL DIC,DR,DIQ

 +4        IF '$DATA(BCHPRNT(BCHFILE,DA,BCHFIEL,"E"))

               SET BCHPRNT(BCHFILE,DA,BCHFIEL,"E")="--"

 +5        SET BCHPRNT=BCHPRNT(BCHFILE,DA,BCHFIEL,"E")

 +6        QUIT 

HEAD      ;ENTRY POINT

 +1        DO HEAD^BCHRLP2

 +2        QUIT