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
