BWGRVLP ; IHS/CMI/LAB - PRINT WH GENERAL REPORT ;15-Feb-2003 21:53;PLS
;;2.0;WOMEN'S HEALTH;**6,8**;MAY 16, 1996
START ;EP - Set up header line, dash line
S BWGRFCNT=0
S X=0,BWGRHEAD="" F S X=$O(^BWGRTRPT(BWGRRPT,12,X)) Q:X'=+X S BWGRHDR=$P(^BWGRI($P(^BWGRTRPT(BWGRRPT,12,X,0),U),0),U,6),BWGRLENG=$P(^BWGRTRPT(BWGRRPT,12,X,0),U,2),BWGRHDR=$E(BWGRHDR,1,BWGRLENG) D
.S J=$L(BWGRHDR),BWGRHEAD=BWGRHEAD_BWGRHDR,K=$P(^BWGRTRPT(BWGRRPT,12,X,0),U,2)+1 F I=J:1:K S BWGRHEAD=BWGRHEAD_" "
.Q
S BWGRDASH="",$P(BWGRDASH,"-",BWGRTCW)="-"
D COVPAGE^BWGRVLP1 ;print cover page - note: if user ^'s out of cover page, processing continues
PROC ;process printing of report
I BWGRCTYP="T" G DONE ;--- if displaying only total, that was done in the cover page - go to done
I BWGRCTYP="C" G DONE ;--- if doing a template, that's already done so goto done
S BWGRPG=0 I '$D(^XTMP("BWGRVL",BWGRJOB,BWGRBTH)) G DONE
S (BWGRSRTV,BWGRFRST)="" K BWGRQUIT
F S BWGRSRTV=$O(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"DATA HITS",BWGRSRTV)) Q:BWGRSRTV=""!($D(BWGRQUIT)) D V
G:$D(BWGRQUIT) DONE
I $Y>(IOSL-4) D HEAD G:$D(BWGRQUIT) DONE
I $D(BWGRRCNT) W !!!,"Total ",$S(BWGRPTVS="P":"Patients",1:"Procedures"),": ",BWGRRCNT
I $G(BWGRPTVS)="R" W !,"Total Patients: ",BWGRPTCT
DONE ;
D DONE^BWGRVLP2
Q
V ;GETS DATA HITS
S BWGRSCNT=0
;get readable sort value
K BWGRPRNT
S BWGRSRTR="",BWGRVIEN=$O(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"DATA HITS",BWGRSRTV,0)) I BWGRVIEN]"" S BWGRCRIT=BWGRSORT D
.I BWGRPTVS="R" S BWGRVREC=^BWPCD(BWGRVIEN,0),DFN=$P(BWGRVREC,U,2) X:$D(^BWGRI(BWGRSORT,3)) ^(3) S BWGRSRTR=BWGRPRNT
.I BWGRPTVS="P" S DFN=BWGRVIEN X:$D(^BWGRI(BWGRSORT,3)) ^(3) S BWGRSRTR=BWGRPRNT
I $G(BWGRSPAG)!($D(BWGRFRST)) D HEAD Q:$D(BWGRQUIT)
K BWGRFRST
S BWGRVIEN=0 F S BWGRVIEN=$O(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"DATA HITS",BWGRSRTV,BWGRVIEN)) Q:BWGRVIEN'=+BWGRVIEN!($D(BWGRQUIT)) D
.I BWGRPTVS="R" S BWGRVREC=^BWPCD(BWGRVIEN,0),DFN=$P(BWGRVREC,U,2) D PRINT Q
.S DFN=BWGRVIEN D PRINT
.Q
Q:$D(BWGRQUIT)
I $Y>(IOSL-3) D HEAD Q:$D(BWGRQUIT)
I $G(BWGRSPAG) W !!,"SUB-TOTAL for ",BWGRSORV," ",BWGRSRTR,": ",BWGRSCNT I BWGRPTVS="R" W " # of PATIENTS: ",$S($D(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PAT COUNT",BWGRSRTV)):^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PAT COUNT",BWGRSRTV),1:0)
I BWGRCTYP="S",(BWGRPTVS="R") W !,?10,$E(BWGRSRTR,1,30),?45,$J(BWGRSCNT,8)," (PROC)",?60,$S($D(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PAT COUNT",BWGRSRTV)):$J(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PAT COUNT",BWGRSRTV),8),1:0)," (PATS)"
I BWGRCTYP="S",(BWGRPTVS="P") W !,?10,$E(BWGRSRTR,1,30),?45,$J(BWGRSCNT,8)
Q
PRINT ;
S BWGRSCNT=BWGRSCNT+1 Q:BWGRCTYP="S"
K ^XTMP("BWGRLINE",$J) S ^XTMP("BWGRLINE",$J,1)=""
I $Y>(IOSL-5) D HEAD Q:$D(BWGRQUIT)
S BWGRI=0 F S BWGRI=$O(^BWGRTRPT(BWGRRPT,12,BWGRI)) Q:BWGRI'=+BWGRI!($D(BWGRQUIT)) S BWGRCRIT=$P(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U) D
.I '$P(^BWGRI(BWGRCRIT,0),U,8) D SINGLE Q
.D MULT
.Q
S BWGRX=0 F S BWGRX=$O(^XTMP("BWGRLINE",$J,BWGRX)) Q:BWGRX'=+BWGRX!($D(BWGRQUIT)) D
.I $Y>(IOSL-4) D HEAD Q:$D(BWGRQUIT)
.W !,^XTMP("BWGRLINE",$J,BWGRX)
Q
SINGLE ;process single valued item
K BWGRPRNT
S BWGRX=0
X:$D(^BWGRI(BWGRCRIT,3)) ^(3)
S BWGRLENG=$P(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U,2),BWGRPRNT=$E(BWGRPRNT,1,BWGRLENG) D
.S J=$L(BWGRPRNT),^XTMP("BWGRLINE",$J,1)=^XTMP("BWGRLINE",$J,1)_BWGRPRNT,K=$P(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U,2)+1 F I=J:1:K S ^XTMP("BWGRLINE",$J,1)=^XTMP("BWGRLINE",$J,1)_" "
.S X=1 F S X=$O(^XTMP("BWGRLINE",$J,X)) Q:X'=+X I $L(^XTMP("BWGRLINE",$J,X))<$L(^XTMP("BWGRLINE",$J,1)) S K=$L(^XTMP("BWGRLINE",$J,X))+1,J=$L(^XTMP("BWGRLINE",$J,1)) F I=K:1:J S ^XTMP("BWGRLINE",$J,X)=^XTMP("BWGRLINE",$J,X)_" "
Q
MULT ;
K BWGRPRNT,BWGRPRNM,BWGRY S (BWGRX,BWGRPCNT)=0
X:$D(^BWGRI(BWGRCRIT,3)) ^(3)
I '$D(BWGRPRNM) S BWGRPRNT="--" D
.S BWGRLENG=$P(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U,2),BWGRPRNT=$E(BWGRPRNT,1,BWGRLENG) D
..S J=$L(BWGRPRNT),^XTMP("BWGRLINE",$J,1)=^XTMP("BWGRLINE",$J,1)_BWGRPRNT,K=$P(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U,2)+1 F I=J:1:K S ^XTMP("BWGRLINE",$J,1)=^XTMP("BWGRLINE",$J,1)_" "
S X=0 F S X=$O(BWGRPRNM(X)) Q:X'=+X D
.I X=1 D Q
..S BWGRLENG=$P(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U,2),BWGRPRNT=$E(BWGRPRNM(1),1,BWGRLENG) D
...S J=$L(BWGRPRNT),^XTMP("BWGRLINE",$J,1)=^XTMP("BWGRLINE",$J,1)_BWGRPRNT,K=$P(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U,2)+1 F I=J:1:K S ^XTMP("BWGRLINE",$J,1)=^XTMP("BWGRLINE",$J,1)_" "
.S BWGRLENG=$P(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U,2),BWGRPRNT=$E(BWGRPRNM(X),1,BWGRLENG) D
..I '$D(^XTMP("BWGRLINE",$J,X)) S ^XTMP("BWGRLINE",$J,X)="",K=$P(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U,2)+1,$P(^XTMP("BWGRLINE",$J,X)," ",($L(^XTMP("BWGRLINE",$J,1))-K))=""
..S J=$L(BWGRPRNT),^XTMP("BWGRLINE",$J,X)=^XTMP("BWGRLINE",$J,X)_BWGRPRNT,K=$P(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U,2)+1 F I=J:1:K S ^XTMP("BWGRLINE",$J,X)=^XTMP("BWGRLINE",$J,X)_" "
S X=1 F S X=$O(^XTMP("BWGRLINE",$J,X)) Q:X'=+X I $L(^XTMP("BWGRLINE",$J,X))<$L(^XTMP("BWGRLINE",$J,1)) S K=$L(^XTMP("BWGRLINE",$J,X))+1,J=$L(^XTMP("BWGRLINE",$J,1)) F I=K:1:J S ^XTMP("BWGRLINE",$J,X)=^XTMP("BWGRLINE",$J,X)_" "
Q
DIQ ;
K BWGRPRNT,BWGRFILE,BWGRFIEL
S BWGRFILE=$P($P(^BWGRI(BWGRCRIT,0),U,4),","),BWGRFIEL=$P($P(^(0),U,4),",",2)
S DIQ(0)="EN",DIQ="BWGRPRNT(",DIC=BWGRFILE,DR=BWGRFIEL D EN^DIQ1 K DIC,DR,DIQ
I '$D(BWGRPRNT(BWGRFILE,DA,BWGRFIEL,"E")) S BWGRPRNT(BWGRFILE,DA,BWGRFIEL,"E")="--"
S BWGRPRNT=BWGRPRNT(BWGRFILE,DA,BWGRFIEL,"E")
Q
HEAD ;ENTRY POINT
D HEAD^BWGRVLP2
Q
WRITEF ;write flat file from global
D WRITEF^BWGRVLP2
Q
BWGRVLP ; IHS/CMI/LAB - PRINT WH GENERAL REPORT ;15-Feb-2003 21:53;PLS
+1 ;;2.0;WOMEN'S HEALTH;**6,8**;MAY 16, 1996
START ;EP - Set up header line, dash line
+1 SET BWGRFCNT=0
+2 SET X=0
SET BWGRHEAD=""
FOR
SET X=$ORDER(^BWGRTRPT(BWGRRPT,12,X))
IF X'=+X
QUIT
SET BWGRHDR=$PIECE(^BWGRI($PIECE(^BWGRTRPT(BWGRRPT,12,X,0),U),0),U,6)
SET BWGRLENG=$PIECE(^BWGRTRPT(BWGRRPT,12,X,0),U,2)
SET BWGRHDR=$EXTRACT(BWGRHDR,1,BWGRLENG)
Begin DoDot:1
+3 SET J=$LENGTH(BWGRHDR)
SET BWGRHEAD=BWGRHEAD_BWGRHDR
SET K=$PIECE(^BWGRTRPT(BWGRRPT,12,X,0),U,2)+1
FOR I=J:1:K
SET BWGRHEAD=BWGRHEAD_" "
+4 QUIT
End DoDot:1
+5 SET BWGRDASH=""
SET $PIECE(BWGRDASH,"-",BWGRTCW)="-"
+6 ;print cover page - note: if user ^'s out of cover page, processing continues
DO COVPAGE^BWGRVLP1
PROC ;process printing of report
+1 ;--- if displaying only total, that was done in the cover page - go to done
IF BWGRCTYP="T"
GOTO DONE
+2 ;--- if doing a template, that's already done so goto done
IF BWGRCTYP="C"
GOTO DONE
+3 SET BWGRPG=0
IF '$DATA(^XTMP("BWGRVL",BWGRJOB,BWGRBTH))
GOTO DONE
+4 SET (BWGRSRTV,BWGRFRST)=""
KILL BWGRQUIT
+5 FOR
SET BWGRSRTV=$ORDER(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"DATA HITS",BWGRSRTV))
IF BWGRSRTV=""!($DATA(BWGRQUIT))
QUIT
DO V
+6 IF $DATA(BWGRQUIT)
GOTO DONE
+7 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(BWGRQUIT)
GOTO DONE
+8 IF $DATA(BWGRRCNT)
WRITE !!!,"Total ",$SELECT(BWGRPTVS="P":"Patients",1:"Procedures"),": ",BWGRRCNT
+9 IF $GET(BWGRPTVS)="R"
WRITE !,"Total Patients: ",BWGRPTCT
DONE ;
+1 DO DONE^BWGRVLP2
+2 QUIT
V ;GETS DATA HITS
+1 SET BWGRSCNT=0
+2 ;get readable sort value
+3 KILL BWGRPRNT
+4 SET BWGRSRTR=""
SET BWGRVIEN=$ORDER(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"DATA HITS",BWGRSRTV,0))
IF BWGRVIEN]""
SET BWGRCRIT=BWGRSORT
Begin DoDot:1
+5 IF BWGRPTVS="R"
SET BWGRVREC=^BWPCD(BWGRVIEN,0)
SET DFN=$PIECE(BWGRVREC,U,2)
IF $DATA(^BWGRI(BWGRSORT,3))
XECUTE ^(3)
SET BWGRSRTR=BWGRPRNT
+6 IF BWGRPTVS="P"
SET DFN=BWGRVIEN
IF $DATA(^BWGRI(BWGRSORT,3))
XECUTE ^(3)
SET BWGRSRTR=BWGRPRNT
End DoDot:1
+7 IF $GET(BWGRSPAG)!($DATA(BWGRFRST))
DO HEAD
IF $DATA(BWGRQUIT)
QUIT
+8 KILL BWGRFRST
+9 SET BWGRVIEN=0
FOR
SET BWGRVIEN=$ORDER(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"DATA HITS",BWGRSRTV,BWGRVIEN))
IF BWGRVIEN'=+BWGRVIEN!($DATA(BWGRQUIT))
QUIT
Begin DoDot:1
+10 IF BWGRPTVS="R"
SET BWGRVREC=^BWPCD(BWGRVIEN,0)
SET DFN=$PIECE(BWGRVREC,U,2)
DO PRINT
QUIT
+11 SET DFN=BWGRVIEN
DO PRINT
+12 QUIT
End DoDot:1
+13 IF $DATA(BWGRQUIT)
QUIT
+14 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(BWGRQUIT)
QUIT
+15 IF $GET(BWGRSPAG)
WRITE !!,"SUB-TOTAL for ",BWGRSORV," ",BWGRSRTR,": ",BWGRSCNT
IF BWGRPTVS="R"
WRITE " # of PATIENTS: ",$SELECT($DATA(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PAT COUNT",BWGRSRTV)):^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PAT COUNT",BWGRSRTV),1:0)
+16 IF BWGRCTYP="S"
IF (BWGRPTVS="R")
WRITE !,?10,$EXTRACT(BWGRSRTR,1,30),?45,$JUSTIFY(BWGRSCNT,8)," (PROC)",?60,$SELECT($DATA(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PAT COUNT",BWGRSRTV)):$JUSTIFY(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PAT COUNT",BWGRSRTV),8),1:0)," (PATS)"
+17 IF BWGRCTYP="S"
IF (BWGRPTVS="P")
WRITE !,?10,$EXTRACT(BWGRSRTR,1,30),?45,$JUSTIFY(BWGRSCNT,8)
+18 QUIT
PRINT ;
+1 SET BWGRSCNT=BWGRSCNT+1
IF BWGRCTYP="S"
QUIT
+2 KILL ^XTMP("BWGRLINE",$JOB)
SET ^XTMP("BWGRLINE",$JOB,1)=""
+3 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(BWGRQUIT)
QUIT
+4 SET BWGRI=0
FOR
SET BWGRI=$ORDER(^BWGRTRPT(BWGRRPT,12,BWGRI))
IF BWGRI'=+BWGRI!($DATA(BWGRQUIT))
QUIT
SET BWGRCRIT=$PIECE(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U)
Begin DoDot:1
+5 IF '$PIECE(^BWGRI(BWGRCRIT,0),U,8)
DO SINGLE
QUIT
+6 DO MULT
+7 QUIT
End DoDot:1
+8 SET BWGRX=0
FOR
SET BWGRX=$ORDER(^XTMP("BWGRLINE",$JOB,BWGRX))
IF BWGRX'=+BWGRX!($DATA(BWGRQUIT))
QUIT
Begin DoDot:1
+9 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(BWGRQUIT)
QUIT
+10 WRITE !,^XTMP("BWGRLINE",$JOB,BWGRX)
End DoDot:1
+11 QUIT
SINGLE ;process single valued item
+1 KILL BWGRPRNT
+2 SET BWGRX=0
+3 IF $DATA(^BWGRI(BWGRCRIT,3))
XECUTE ^(3)
+4 SET BWGRLENG=$PIECE(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U,2)
SET BWGRPRNT=$EXTRACT(BWGRPRNT,1,BWGRLENG)
Begin DoDot:1
+5 SET J=$LENGTH(BWGRPRNT)
SET ^XTMP("BWGRLINE",$JOB,1)=^XTMP("BWGRLINE",$JOB,1)_BWGRPRNT
SET K=$PIECE(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U,2)+1
FOR I=J:1:K
SET ^XTMP("BWGRLINE",$JOB,1)=^XTMP("BWGRLINE",$JOB,1)_" "
+6 SET X=1
FOR
SET X=$ORDER(^XTMP("BWGRLINE",$JOB,X))
IF X'=+X
QUIT
IF $LENGTH(^XTMP("BWGRLINE",$JOB,X))<$LENGTH(^XTMP("BWGRLINE",$JOB,1))
SET K=$LENGTH(^XTMP("BWGRLINE",$JOB,X))+1
SET J=$LENGTH(^XTMP("BWGRLINE",$JOB,1))
FOR I=K:1:J
SET ^XTMP("BWGRLINE",$JOB,X)=^XTMP("BWGRLINE",$JOB,X)_" "
End DoDot:1
+7 QUIT
MULT ;
+1 KILL BWGRPRNT,BWGRPRNM,BWGRY
SET (BWGRX,BWGRPCNT)=0
+2 IF $DATA(^BWGRI(BWGRCRIT,3))
XECUTE ^(3)
+3 IF '$DATA(BWGRPRNM)
SET BWGRPRNT="--"
Begin DoDot:1
+4 SET BWGRLENG=$PIECE(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U,2)
SET BWGRPRNT=$EXTRACT(BWGRPRNT,1,BWGRLENG)
Begin DoDot:2
+5 SET J=$LENGTH(BWGRPRNT)
SET ^XTMP("BWGRLINE",$JOB,1)=^XTMP("BWGRLINE",$JOB,1)_BWGRPRNT
SET K=$PIECE(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U,2)+1
FOR I=J:1:K
SET ^XTMP("BWGRLINE",$JOB,1)=^XTMP("BWGRLINE",$JOB,1)_" "
End DoDot:2
End DoDot:1
+6 SET X=0
FOR
SET X=$ORDER(BWGRPRNM(X))
IF X'=+X
QUIT
Begin DoDot:1
+7 IF X=1
Begin DoDot:2
+8 SET BWGRLENG=$PIECE(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U,2)
SET BWGRPRNT=$EXTRACT(BWGRPRNM(1),1,BWGRLENG)
Begin DoDot:3
+9 SET J=$LENGTH(BWGRPRNT)
SET ^XTMP("BWGRLINE",$JOB,1)=^XTMP("BWGRLINE",$JOB,1)_BWGRPRNT
SET K=$PIECE(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U,2)+1
FOR I=J:1:K
SET ^XTMP("BWGRLINE",$JOB,1)=^XTMP("BWGRLINE",$JOB,1)_" "
End DoDot:3
End DoDot:2
QUIT
+10 SET BWGRLENG=$PIECE(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U,2)
SET BWGRPRNT=$EXTRACT(BWGRPRNM(X),1,BWGRLENG)
Begin DoDot:2
+11 IF '$DATA(^XTMP("BWGRLINE",$JOB,X))
SET ^XTMP("BWGRLINE",$JOB,X)=""
SET K=$PIECE(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U,2)+1
SET $PIECE(^XTMP("BWGRLINE",$JOB,X)," ",($LENGTH(^XTMP("BWGRLINE",$JOB,1))-K))=""
+12 SET J=$LENGTH(BWGRPRNT)
SET ^XTMP("BWGRLINE",$JOB,X)=^XTMP("BWGRLINE",$JOB,X)_BWGRPRNT
SET K=$PIECE(^BWGRTRPT(BWGRRPT,12,BWGRI,0),U,2)+1
FOR I=J:1:K
SET ^XTMP("BWGRLINE",$JOB,X)=^XTMP("BWGRLINE",$JOB,X)_" "
End DoDot:2
End DoDot:1
+13 SET X=1
FOR
SET X=$ORDER(^XTMP("BWGRLINE",$JOB,X))
IF X'=+X
QUIT
IF $LENGTH(^XTMP("BWGRLINE",$JOB,X))<$LENGTH(^XTMP("BWGRLINE",$JOB,1))
SET K=$LENGTH(^XTMP("BWGRLINE",$JOB,X))+1
SET J=$LENGTH(^XTMP("BWGRLINE",$JOB,1))
FOR I=K:1:J
SET ^XTMP("BWGRLINE",$JOB,X)=^XTMP("BWGRLINE",$JOB,X)_" "
+14 QUIT
DIQ ;
+1 KILL BWGRPRNT,BWGRFILE,BWGRFIEL
+2 SET BWGRFILE=$PIECE($PIECE(^BWGRI(BWGRCRIT,0),U,4),",")
SET BWGRFIEL=$PIECE($PIECE(^(0),U,4),",",2)
+3 SET DIQ(0)="EN"
SET DIQ="BWGRPRNT("
SET DIC=BWGRFILE
SET DR=BWGRFIEL
DO EN^DIQ1
KILL DIC,DR,DIQ
+4 IF '$DATA(BWGRPRNT(BWGRFILE,DA,BWGRFIEL,"E"))
SET BWGRPRNT(BWGRFILE,DA,BWGRFIEL,"E")="--"
+5 SET BWGRPRNT=BWGRPRNT(BWGRFILE,DA,BWGRFIEL,"E")
+6 QUIT
HEAD ;ENTRY POINT
+1 DO HEAD^BWGRVLP2
+2 QUIT
WRITEF ;write flat file from global
+1 DO WRITEF^BWGRVLP2
+2 QUIT
