BNIGVLP8 ; IHS/CMI/LAB - print delimited ;
;;1.0;BNI CPHD ACTIVITY DATASYSTEM;;DEC 20, 2006
;IHS/TUCSON/LAB - added killing of BNIGPRNT to V subroutine 05/19/97
;IHS/TUCSON/LAB - modified subroutine FLAT - patch 1 - 05/27/97
DELIMIT ;EP - Set up header line, dash line
S BNIGFCNT=0,BNIGUIC=1
K ^TMP($J,"BNIGDELIMITED")
S BNIGDELC=0,BNIGPIEC=0
I BNIGPTVS="R" S BNIGHDR="RECORD IEN",BNIGPIEC=1
S X=0,BNIGHEAD="" F S X=$O(^BNIRTMP(BNIGRPT,12,X)) Q:X'=+X D
.S BNIGPIEC=BNIGPIEC+1
.S H=$P(^BNIGRI($P(^BNIRTMP(BNIGRPT,12,X,0),U),0),U,6)
.S $P(BNIGHDR,U,BNIGPIEC)=H
.Q
I '$G(BNIGUI) D COVPAGE^BNIGVLP1 ;print cover page - note: if user ^'s out of cover page, processing continues
I $G(BNIGUI) D COVPAGE^BNIGVLP3
PROC ;process printing of report
I $G(BNIGUI) S BNIGUIC=BNIC S ^BNIGUI(BNIIEN,12,BNIGUIC,0)=BNIGHDR G PROC1
S Y=0 I BNIGDELT="F" D OPEN Q:Y=1
W !,BNIGHDR,!
PROC1 ;
I '$D(^XTMP("BNIGVL",BNIGJOB,BNIGBTH)) W !,"NO DATA TO REPORT" G DONE
S (BNIGSRTV,BNIGFRST)="" K BNIGQUIT
F S BNIGSRTV=$O(^XTMP("BNIGVL",BNIGJOB,BNIGBTH,"DATA HITS",BNIGSRTV)) Q:BNIGSRTV=""!($D(BNIGQUIT)) D V
DONE ;
;write out delimited file
I '$G(BNIGUI),BNIGDELT="F" D ^%ZISC
K ^XTMP("BNIGVL",BNIGJOB,BNIGBT),^TMP($J,"BNIGDELIMITED")
D DEL^BNIGVL
K BNIGBD,BNIGSD,BNIGED,BNIGEDD,BNIGBDD,BNIGRPT,BNIGHEAD,BNIGLINE,BNIGL,BNIGRCNT,BNIGI,BNIGCRIT,BNIGVIEN,BNIGVREC,BNIGJOB,BNIGBT,BNIGBTH,BNIGQUIT,BNIGHDR,BNIGDASH,BNIGLENG,BNIGPCNT,BNIGTCW,BNIGODAT,BNIGPG,AUPNDAYS,AUPNPAT,AUPNDOD,AUPNDOB,AUPNSEX
K BNIGSORT,BNIGSRT,BNIGSORX,BNIGFILE,BNIGFIEL,BNIGPRNT,BNIGX,BNIGTYPE,BNIGFOUN,D0,J,K,L,BNIGPRNM,BNIGTEST,BNIGSEAT,BNIGLHDR,BNIGFRST
D EN^XBVK("BNIG")
Q
V ;GETS DATA HITS
S BNIGCNT=0
;get readable sort value
K BNIGPRNT
S BNIGSRTR="",BNIGVIEN=$O(^XTMP("BNIGVL",BNIGJOB,BNIGBTH,"DATA HITS",BNIGSRTV,0)) I BNIGVIEN]"" S BNIGCRIT=BNIGSORT D
.I BNIGPTVS="R" S BNIGVREC=^BNIREC(BNIGVIEN,0) X:$D(^BNIGRI(BNIGSORT,3)) ^(3) S BNIGSRTR=BNIGPRNT
K BNIGFRST
S BNIGVIEN=0 F S BNIGVIEN=$O(^XTMP("BNIGVL",BNIGJOB,BNIGBTH,"DATA HITS",BNIGSRTV,BNIGVIEN)) Q:BNIGVIEN'=+BNIGVIEN!($D(BNIGQUIT)) D
.I BNIGPTVS="R" S BNIGVREC=^BNIREC(BNIGVIEN,0) D PRINT Q
.Q
Q
PRINT ;
K ^XTMP("BNIGLINE",$J) S ^XTMP("BNIGLINE",$J,1)=""
K BNIGDELD
S BNIGPIEC=0,BNIGLINE=1,BNIGCNT=BNIGCNT+1
I BNIGPTVS="R" S BNIGDELD(1,"S")=BNIGVIEN,BNIGPIEC=1
S BNIGI=0 F S BNIGI=$O(^BNIRTMP(BNIGRPT,12,BNIGI)) Q:BNIGI'=+BNIGI!($D(BNIGQUIT)) S BNIGCRIT=$P(^BNIRTMP(BNIGRPT,12,BNIGI,0),U) D
.S BNIGPIEC=BNIGPIEC+1
.I '$P(^BNIGRI(BNIGCRIT,0),U,8) D SINGLE Q
.D MULT
.Q
K BNIGDELP
F X=1:1:BNIGLINE D
.S BNIGCNT=BNIGCNT+1
.F P=1:1:BNIGPIEC D
..S V=$O(BNIGDELD(P,""))
..I V="S" S D=BNIGDELD(P,V),$P(BNIGDELP(BNIGCNT),U,P)=D
..I V="M" S D=$S($P(BNIGDELD(P,V),"|",X)]"":$P(BNIGDELD(P,V),"|",X),1:"--"),$P(BNIGDELP(BNIGCNT),U,P)=D
I '$G(BNIGUI) S X=0 F S X=$O(BNIGDELP(X)) Q:X'=+X W BNIGDELP(X),!
I $G(BNIGUI) D
.S (C,X)=0 F S X=$O(BNIGDELP(X)) Q:X'=+X S BNIGUIC=BNIGUIC+1,^BNIGUI(BNIIEN,12,BNIGUIC,0)=BNIGDELP(X)
.S ^BNIGUI(BNIIEN,12,0)="^90512.0812^"_BNIGUIC_"^"_BNIGUIC_"^"_DT
Q
SINGLE ;process single valued item
K BNIGPRNT
S BNIGX=0
X:$D(^BNIGRI(BNIGCRIT,3)) ^(3)
I BNIGPRNT="" S BNIGPRNT="--"
S BNIGDELD(BNIGPIEC,"S")=BNIGPRNT
Q
MULT ;
K BNIGPRNT,BNIGPRNM,BNIGY S (BNIGX,BNIGPCNT)=0
X:$D(^BNIGRI(BNIGCRIT,3)) ^(3)
;if 13th, then $o through delete bad ones and then reorder/number
;new logic here to screen if user wants to screen
I $P(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,3) D
.;does this one match selected ones?
.S X=0 F S X=$O(BNIGPRNM(X)) Q:X'=+X D
..S Z=$G(BNIGPRNM(X,"I")) I Z="" K BNIGPRNM(X) Q
..I '$D(^BNIGRTMP(BNIGRPT,11,BNIGCRIT,11,"B",Z)) K BNIGPRNM(X)
K Y S (X,C)=0 F S X=$O(BNIGPRNM(X)) Q:X'=+X S C=C+1,Y(C)=BNIGPRNM(X)
I C>BNIGLINE S BNIGLINE=C
K BNIGPRNM S X=0 F S X=$O(Y(X)) Q:X'=+X S BNIGPRNM(X)=Y(X)
I '$D(BNIGPRNM) S BNIGPRNT="--" D
.S BNIGDELD(BNIGPIEC,"M")=BNIGPRNT
S X=0 F S X=$O(BNIGPRNM(X)) Q:X'=+X D
.S $P(BNIGDELD(BNIGPIEC,"M"),"|",X)=BNIGPRNM(X)
Q
DIQ ;
K BNIGPRNT,BNIGFILE,BNIGFIEL
S BNIGFILE=$P($P(^BNIGRI(BNIGCRIT,0),U,4),","),BNIGFIEL=$P($P(^(0),U,4),",",2)
S DIQ(0)="EN",DIQ="BNIGPRNT(",DIC=BNIGFILE,DR=BNIGFIEL D EN^DIQ1 K DIC,DR,DIQ
I '$D(BNIGPRNT(BNIGFILE,DA,BNIGFIEL,"E")) S BNIGPRNT(BNIGFILE,DA,BNIGFIEL,"E")="--"
S BNIGPRNT=BNIGPRNT(BNIGFILE,DA,BNIGFIEL,"E")
Q
OPEN ;write flat file from global
;if screen selected do screen
;USE GS FROM GPRA TO OPEN AND WRITE FILE
;I BNIGDELT="S" D SCREEN Q
I $G(BNIGUI) Q
S Y=$$OPEN^%ZISH(BNIGHDIR,BNIGDELF,"W")
I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file to write out DELIMITED data. Notify programmer." Q
U IO
Q
BNIGVLP8 ; IHS/CMI/LAB - print delimited ;
+1 ;;1.0;BNI CPHD ACTIVITY DATASYSTEM;;DEC 20, 2006
+2 ;IHS/TUCSON/LAB - added killing of BNIGPRNT to V subroutine 05/19/97
+3 ;IHS/TUCSON/LAB - modified subroutine FLAT - patch 1 - 05/27/97
DELIMIT ;EP - Set up header line, dash line
+1 SET BNIGFCNT=0
SET BNIGUIC=1
+2 KILL ^TMP($JOB,"BNIGDELIMITED")
+3 SET BNIGDELC=0
SET BNIGPIEC=0
+4 IF BNIGPTVS="R"
SET BNIGHDR="RECORD IEN"
SET BNIGPIEC=1
+5 SET X=0
SET BNIGHEAD=""
FOR
SET X=$ORDER(^BNIRTMP(BNIGRPT,12,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET BNIGPIEC=BNIGPIEC+1
+7 SET H=$PIECE(^BNIGRI($PIECE(^BNIRTMP(BNIGRPT,12,X,0),U),0),U,6)
+8 SET $PIECE(BNIGHDR,U,BNIGPIEC)=H
+9 QUIT
End DoDot:1
+10 ;print cover page - note: if user ^'s out of cover page, processing continues
IF '$GET(BNIGUI)
DO COVPAGE^BNIGVLP1
+11 IF $GET(BNIGUI)
DO COVPAGE^BNIGVLP3
PROC ;process printing of report
+1 IF $GET(BNIGUI)
SET BNIGUIC=BNIC
SET ^BNIGUI(BNIIEN,12,BNIGUIC,0)=BNIGHDR
GOTO PROC1
+2 SET Y=0
IF BNIGDELT="F"
DO OPEN
IF Y=1
QUIT
+3 WRITE !,BNIGHDR,!
PROC1 ;
+1 IF '$DATA(^XTMP("BNIGVL",BNIGJOB,BNIGBTH))
WRITE !,"NO DATA TO REPORT"
GOTO DONE
+2 SET (BNIGSRTV,BNIGFRST)=""
KILL BNIGQUIT
+3 FOR
SET BNIGSRTV=$ORDER(^XTMP("BNIGVL",BNIGJOB,BNIGBTH,"DATA HITS",BNIGSRTV))
IF BNIGSRTV=""!($DATA(BNIGQUIT))
QUIT
DO V
DONE ;
+1 ;write out delimited file
+2 IF '$GET(BNIGUI)
IF BNIGDELT="F"
DO ^%ZISC
+3 KILL ^XTMP("BNIGVL",BNIGJOB,BNIGBT),^TMP($JOB,"BNIGDELIMITED")
+4 DO DEL^BNIGVL
+5 KILL BNIGBD,BNIGSD,BNIGED,BNIGEDD,BNIGBDD,BNIGRPT,BNIGHEAD,BNIGLINE,BNIGL,BNIGRCNT,BNIGI,BNIGCRIT,BNIGVIEN,BNIGVREC,BNIGJOB,BNIGBT,BNIGBTH,BNIGQUIT,BNIGHDR,BNIGDASH,BNIGLENG,BNIGPCNT,BNIGTCW,BNIGODAT,BNIGPG,AUPNDAYS,AUPNPAT,AUPNDOD,AUPNDOB,AUPN
SEX
+6 KILL BNIGSORT,BNIGSRT,BNIGSORX,BNIGFILE,BNIGFIEL,BNIGPRNT,BNIGX,BNIGTYPE,BNIGFOUN,D0,J,K,L,BNIGPRNM,BNIGTEST,BNIGSEAT,BNIGLHDR,BNIGFRST
+7 DO EN^XBVK("BNIG")
+8 QUIT
V ;GETS DATA HITS
+1 SET BNIGCNT=0
+2 ;get readable sort value
+3 KILL BNIGPRNT
+4 SET BNIGSRTR=""
SET BNIGVIEN=$ORDER(^XTMP("BNIGVL",BNIGJOB,BNIGBTH,"DATA HITS",BNIGSRTV,0))
IF BNIGVIEN]""
SET BNIGCRIT=BNIGSORT
Begin DoDot:1
+5 IF BNIGPTVS="R"
SET BNIGVREC=^BNIREC(BNIGVIEN,0)
IF $DATA(^BNIGRI(BNIGSORT,3))
XECUTE ^(3)
SET BNIGSRTR=BNIGPRNT
End DoDot:1
+6 KILL BNIGFRST
+7 SET BNIGVIEN=0
FOR
SET BNIGVIEN=$ORDER(^XTMP("BNIGVL",BNIGJOB,BNIGBTH,"DATA HITS",BNIGSRTV,BNIGVIEN))
IF BNIGVIEN'=+BNIGVIEN!($DATA(BNIGQUIT))
QUIT
Begin DoDot:1
+8 IF BNIGPTVS="R"
SET BNIGVREC=^BNIREC(BNIGVIEN,0)
DO PRINT
QUIT
+9 QUIT
End DoDot:1
+10 QUIT
PRINT ;
+1 KILL ^XTMP("BNIGLINE",$JOB)
SET ^XTMP("BNIGLINE",$JOB,1)=""
+2 KILL BNIGDELD
+3 SET BNIGPIEC=0
SET BNIGLINE=1
SET BNIGCNT=BNIGCNT+1
+4 IF BNIGPTVS="R"
SET BNIGDELD(1,"S")=BNIGVIEN
SET BNIGPIEC=1
+5 SET BNIGI=0
FOR
SET BNIGI=$ORDER(^BNIRTMP(BNIGRPT,12,BNIGI))
IF BNIGI'=+BNIGI!($DATA(BNIGQUIT))
QUIT
SET BNIGCRIT=$PIECE(^BNIRTMP(BNIGRPT,12,BNIGI,0),U)
Begin DoDot:1
+6 SET BNIGPIEC=BNIGPIEC+1
+7 IF '$PIECE(^BNIGRI(BNIGCRIT,0),U,8)
DO SINGLE
QUIT
+8 DO MULT
+9 QUIT
End DoDot:1
+10 KILL BNIGDELP
+11 FOR X=1:1:BNIGLINE
Begin DoDot:1
+12 SET BNIGCNT=BNIGCNT+1
+13 FOR P=1:1:BNIGPIEC
Begin DoDot:2
+14 SET V=$ORDER(BNIGDELD(P,""))
+15 IF V="S"
SET D=BNIGDELD(P,V)
SET $PIECE(BNIGDELP(BNIGCNT),U,P)=D
+16 IF V="M"
SET D=$SELECT($PIECE(BNIGDELD(P,V),"|",X)]"":$PIECE(BNIGDELD(P,V),"|",X),1:"--")
SET $PIECE(BNIGDELP(BNIGCNT),U,P)=D
End DoDot:2
End DoDot:1
+17 IF '$GET(BNIGUI)
SET X=0
FOR
SET X=$ORDER(BNIGDELP(X))
IF X'=+X
QUIT
WRITE BNIGDELP(X),!
+18 IF $GET(BNIGUI)
Begin DoDot:1
+19 SET (C,X)=0
FOR
SET X=$ORDER(BNIGDELP(X))
IF X'=+X
QUIT
SET BNIGUIC=BNIGUIC+1
SET ^BNIGUI(BNIIEN,12,BNIGUIC,0)=BNIGDELP(X)
+20 SET ^BNIGUI(BNIIEN,12,0)="^90512.0812^"_BNIGUIC_"^"_BNIGUIC_"^"_DT
End DoDot:1
+21 QUIT
SINGLE ;process single valued item
+1 KILL BNIGPRNT
+2 SET BNIGX=0
+3 IF $DATA(^BNIGRI(BNIGCRIT,3))
XECUTE ^(3)
+4 IF BNIGPRNT=""
SET BNIGPRNT="--"
+5 SET BNIGDELD(BNIGPIEC,"S")=BNIGPRNT
+6 QUIT
MULT ;
+1 KILL BNIGPRNT,BNIGPRNM,BNIGY
SET (BNIGX,BNIGPCNT)=0
+2 IF $DATA(^BNIGRI(BNIGCRIT,3))
XECUTE ^(3)
+3 ;if 13th, then $o through delete bad ones and then reorder/number
+4 ;new logic here to screen if user wants to screen
+5 IF $PIECE(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,3)
Begin DoDot:1
+6 ;does this one match selected ones?
+7 SET X=0
FOR
SET X=$ORDER(BNIGPRNM(X))
IF X'=+X
QUIT
Begin DoDot:2
+8 SET Z=$GET(BNIGPRNM(X,"I"))
IF Z=""
KILL BNIGPRNM(X)
QUIT
+9 IF '$DATA(^BNIGRTMP(BNIGRPT,11,BNIGCRIT,11,"B",Z))
KILL BNIGPRNM(X)
End DoDot:2
End DoDot:1
+10 KILL Y
SET (X,C)=0
FOR
SET X=$ORDER(BNIGPRNM(X))
IF X'=+X
QUIT
SET C=C+1
SET Y(C)=BNIGPRNM(X)
+11 IF C>BNIGLINE
SET BNIGLINE=C
+12 KILL BNIGPRNM
SET X=0
FOR
SET X=$ORDER(Y(X))
IF X'=+X
QUIT
SET BNIGPRNM(X)=Y(X)
+13 IF '$DATA(BNIGPRNM)
SET BNIGPRNT="--"
Begin DoDot:1
+14 SET BNIGDELD(BNIGPIEC,"M")=BNIGPRNT
End DoDot:1
+15 SET X=0
FOR
SET X=$ORDER(BNIGPRNM(X))
IF X'=+X
QUIT
Begin DoDot:1
+16 SET $PIECE(BNIGDELD(BNIGPIEC,"M"),"|",X)=BNIGPRNM(X)
End DoDot:1
+17 QUIT
DIQ ;
+1 KILL BNIGPRNT,BNIGFILE,BNIGFIEL
+2 SET BNIGFILE=$PIECE($PIECE(^BNIGRI(BNIGCRIT,0),U,4),",")
SET BNIGFIEL=$PIECE($PIECE(^(0),U,4),",",2)
+3 SET DIQ(0)="EN"
SET DIQ="BNIGPRNT("
SET DIC=BNIGFILE
SET DR=BNIGFIEL
DO EN^DIQ1
KILL DIC,DR,DIQ
+4 IF '$DATA(BNIGPRNT(BNIGFILE,DA,BNIGFIEL,"E"))
SET BNIGPRNT(BNIGFILE,DA,BNIGFIEL,"E")="--"
+5 SET BNIGPRNT=BNIGPRNT(BNIGFILE,DA,BNIGFIEL,"E")
+6 QUIT
OPEN ;write flat file from global
+1 ;if screen selected do screen
+2 ;USE GS FROM GPRA TO OPEN AND WRITE FILE
+3 ;I BNIGDELT="S" D SCREEN Q
+4 IF $GET(BNIGUI)
QUIT
+5 SET Y=$$OPEN^%ZISH(BNIGHDIR,BNIGDELF,"W")
+6 IF Y=1
IF '$DATA(ZTQUEUED)
WRITE !!,"Cannot open host file to write out DELIMITED data. Notify programmer."
QUIT
+7 USE IO
+8 QUIT
