- BNIGVLP ; IHS/CMI/LAB - print bni general retrieval ;
- ;;1.0;BNI CPHD ACTIVITY DATASYSTEM;;DEC 20, 2006
- START ;EP - Set up header line, dash line
- S BNIGFCNT=0
- S BNIIOSL=$S($G(BNIGUI):55,1:$G(IOSL))
- I BNIGCTYP="L" D DELIMIT^BNIGVLP8 Q
- S X=0,BNIGHEAD="" F S X=$O(^BNIRTMP(BNIGRPT,12,X)) Q:X'=+X S BNIGHDR=$P(^BNIGRI($P(^BNIRTMP(BNIGRPT,12,X,0),U),0),U,6),BNIGLENG=$P(^BNIRTMP(BNIGRPT,12,X,0),U,2),BNIGHDR=$E(BNIGHDR,1,BNIGLENG) D
- .S J=$L(BNIGHDR),BNIGHEAD=BNIGHEAD_BNIGHDR,K=$P(^BNIRTMP(BNIGRPT,12,X,0),U,2)+1 F I=J:1:K S BNIGHEAD=BNIGHEAD_" "
- .Q
- S BNIGDASH="",$P(BNIGDASH,"-",BNIGTCW)="-"
- D COVPAGE^BNIGVLP1 ;print cover page - note: if user ^'s out of cover page, processing continues
- PROC ;process printing of report
- I BNIGCTYP="T" G DONE ;--- if displaying only total, that was done in the cover page - go to done
- I BNIGCTYP="C" G DONE ;--- if doing a template, that's already done so goto done
- S BNIGPG=0 I '$D(^XTMP("BNIGVL",BNIGJOB,BNIGBTH)) G DONE
- S (BNIGSRTV,BNIGFRST)="" K BNIGQUIT
- D HEAD F S BNIGSRTV=$O(^XTMP("BNIGVL",BNIGJOB,BNIGBTH,"DATA HITS",BNIGSRTV)) Q:BNIGSRTV=""!($D(BNIGQUIT)) D V
- G:$D(BNIGQUIT) DONE
- I $Y>(BNIIOSL-4) D HEAD G:$D(BNIGQUIT) DONE
- I $D(BNIGRCNT) W !!!,"Total CPHAD Activity records: ",BNIGRCNT
- DONE ;
- D DONE^BNIGVLP2
- Q
- V ;GETS DATA HITS
- S BNIGSCNT=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
- I $G(BNIGSPAG)!($D(BNIGFRST)) D HEAD Q:$D(BNIGQUIT)
- 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:$D(BNIGQUIT)
- I $Y>(BNIIOSL-3) D HEAD Q:$D(BNIGQUIT)
- I $G(BNIGSPAG) W !!,"SUB-TOTAL for ",BNIGSORV," ",BNIGSRTR,": ",BNIGSCNT I BNIGCTYP="S",(BNIGPTVS="R") W !,?10,$E(BNIGSRTR,1,30),?45,$J(BNIGSCNT,8)
- I BNIGCTYP="S" W !,?10,$E(BNIGSRTR,1,30),?45,$J(BNIGSCNT,8)
- Q
- PRINT ;
- S BNIGSCNT=BNIGSCNT+1 Q:BNIGCTYP="S"
- K ^XTMP("BNIGLINE",$J) S ^XTMP("BNIGLINE",$J,1)=""
- I $Y>(BNIIOSL-5) D HEAD Q:$D(BNIGQUIT)
- 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
- .I '$P(^BNIGRI(BNIGCRIT,0),U,8) D SINGLE Q
- .D MULT
- .Q
- S BNIGX=0 F S BNIGX=$O(^XTMP("BNIGLINE",$J,BNIGX)) Q:BNIGX'=+BNIGX!($D(BNIGQUIT)) D
- .I $Y>(BNIIOSL-4) D HEAD Q:$D(BNIGQUIT)
- .W !,^XTMP("BNIGLINE",$J,BNIGX)
- Q
- SINGLE ;process single valued item
- K BNIGPRNT
- S BNIGX=0
- X:$D(^BNIGRI(BNIGCRIT,3)) ^(3)
- S BNIGLENG=$P(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,2),BNIGPRNT=$E(BNIGPRNT,1,BNIGLENG) D
- .S J=$L(BNIGPRNT),^XTMP("BNIGLINE",$J,1)=^XTMP("BNIGLINE",$J,1)_BNIGPRNT,K=$P(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,2)+1 F I=J:1:K S ^XTMP("BNIGLINE",$J,1)=^XTMP("BNIGLINE",$J,1)_" "
- .S X=1 F S X=$O(^XTMP("BNIGLINE",$J,X)) Q:X'=+X I $L(^XTMP("BNIGLINE",$J,X))<$L(^XTMP("BNIGLINE",$J,1)) S K=$L(^XTMP("BNIGLINE",$J,X))+1,J=$L(^XTMP("BNIGLINE",$J,1)) F I=K:1:J S ^XTMP("BNIGLINE",$J,X)=^XTMP("BNIGLINE",$J,X)_" "
- Q
- MULT ;
- K BNIGPRNT,BNIGPRNM,BNIGY S (BNIGX,BNIGPCNT)=0
- X:$D(^BNIGRI(BNIGCRIT,3)) ^(3)
- I '$D(BNIGPRNM) S BNIGPRNT="--" D
- .S BNIGLENG=$P(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,2),BNIGPRNT=$E(BNIGPRNT,1,BNIGLENG) D
- ..S J=$L(BNIGPRNT),^XTMP("BNIGLINE",$J,1)=^XTMP("BNIGLINE",$J,1)_BNIGPRNT,K=$P(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,2)+1 F I=J:1:K S ^XTMP("BNIGLINE",$J,1)=^XTMP("BNIGLINE",$J,1)_" "
- S X=0 F S X=$O(BNIGPRNM(X)) Q:X'=+X D
- .I X=1 D Q
- ..S BNIGLENG=$P(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,2),BNIGPRNT=$E(BNIGPRNM(1),1,BNIGLENG) D
- ...S J=$L(BNIGPRNT),^XTMP("BNIGLINE",$J,1)=^XTMP("BNIGLINE",$J,1)_BNIGPRNT,K=$P(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,2)+1 F I=J:1:K S ^XTMP("BNIGLINE",$J,1)=^XTMP("BNIGLINE",$J,1)_" "
- .S BNIGLENG=$P(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,2),BNIGPRNT=$E(BNIGPRNM(X),1,BNIGLENG) D
- ..I '$D(^XTMP("BNIGLINE",$J,X)) S ^XTMP("BNIGLINE",$J,X)="",K=$P(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,2)+1,$P(^XTMP("BNIGLINE",$J,X)," ",($L(^XTMP("BNIGLINE",$J,1))-K))=""
- ..S J=$L(BNIGPRNT),^XTMP("BNIGLINE",$J,X)=^XTMP("BNIGLINE",$J,X)_BNIGPRNT,K=$P(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,2)+1 F I=J:1:K S ^XTMP("BNIGLINE",$J,X)=^XTMP("BNIGLINE",$J,X)_" "
- S X=1 F S X=$O(^XTMP("BNIGLINE",$J,X)) Q:X'=+X I $L(^XTMP("BNIGLINE",$J,X))<$L(^XTMP("BNIGLINE",$J,1)) S K=$L(^XTMP("BNIGLINE",$J,X))+1,J=$L(^XTMP("BNIGLINE",$J,1)) F I=K:1:J S ^XTMP("BNIGLINE",$J,X)=^XTMP("BNIGLINE",$J,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
- HEAD ;ENTRY POINT
- D HEAD^BNIGVLP2
- Q
- BNIGVLP ; IHS/CMI/LAB - print bni general retrieval ;
- +1 ;;1.0;BNI CPHD ACTIVITY DATASYSTEM;;DEC 20, 2006
- START ;EP - Set up header line, dash line
- +1 SET BNIGFCNT=0
- +2 SET BNIIOSL=$SELECT($GET(BNIGUI):55,1:$GET(IOSL))
- +3 IF BNIGCTYP="L"
- DO DELIMIT^BNIGVLP8
- QUIT
- +4 SET X=0
- SET BNIGHEAD=""
- FOR
- SET X=$ORDER(^BNIRTMP(BNIGRPT,12,X))
- IF X'=+X
- QUIT
- SET BNIGHDR=$PIECE(^BNIGRI($PIECE(^BNIRTMP(BNIGRPT,12,X,0),U),0),U,6)
- SET BNIGLENG=$PIECE(^BNIRTMP(BNIGRPT,12,X,0),U,2)
- SET BNIGHDR=$EXTRACT(BNIGHDR,1,BNIGLENG)
- Begin DoDot:1
- +5 SET J=$LENGTH(BNIGHDR)
- SET BNIGHEAD=BNIGHEAD_BNIGHDR
- SET K=$PIECE(^BNIRTMP(BNIGRPT,12,X,0),U,2)+1
- FOR I=J:1:K
- SET BNIGHEAD=BNIGHEAD_" "
- +6 QUIT
- End DoDot:1
- +7 SET BNIGDASH=""
- SET $PIECE(BNIGDASH,"-",BNIGTCW)="-"
- +8 ;print cover page - note: if user ^'s out of cover page, processing continues
- DO COVPAGE^BNIGVLP1
- PROC ;process printing of report
- +1 ;--- if displaying only total, that was done in the cover page - go to done
- IF BNIGCTYP="T"
- GOTO DONE
- +2 ;--- if doing a template, that's already done so goto done
- IF BNIGCTYP="C"
- GOTO DONE
- +3 SET BNIGPG=0
- IF '$DATA(^XTMP("BNIGVL",BNIGJOB,BNIGBTH))
- GOTO DONE
- +4 SET (BNIGSRTV,BNIGFRST)=""
- KILL BNIGQUIT
- +5 DO HEAD
- FOR
- SET BNIGSRTV=$ORDER(^XTMP("BNIGVL",BNIGJOB,BNIGBTH,"DATA HITS",BNIGSRTV))
- IF BNIGSRTV=""!($DATA(BNIGQUIT))
- QUIT
- DO V
- +6 IF $DATA(BNIGQUIT)
- GOTO DONE
- +7 IF $Y>(BNIIOSL-4)
- DO HEAD
- IF $DATA(BNIGQUIT)
- GOTO DONE
- +8 IF $DATA(BNIGRCNT)
- WRITE !!!,"Total CPHAD Activity records: ",BNIGRCNT
- DONE ;
- +1 DO DONE^BNIGVLP2
- +2 QUIT
- V ;GETS DATA HITS
- +1 SET BNIGSCNT=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 IF $GET(BNIGSPAG)!($DATA(BNIGFRST))
- DO HEAD
- IF $DATA(BNIGQUIT)
- QUIT
- +7 KILL BNIGFRST
- +8 SET BNIGVIEN=0
- FOR
- SET BNIGVIEN=$ORDER(^XTMP("BNIGVL",BNIGJOB,BNIGBTH,"DATA HITS",BNIGSRTV,BNIGVIEN))
- IF BNIGVIEN'=+BNIGVIEN!($DATA(BNIGQUIT))
- QUIT
- Begin DoDot:1
- +9 IF BNIGPTVS="R"
- SET BNIGVREC=^BNIREC(BNIGVIEN,0)
- DO PRINT
- QUIT
- +10 QUIT
- End DoDot:1
- +11 IF $DATA(BNIGQUIT)
- QUIT
- +12 IF $Y>(BNIIOSL-3)
- DO HEAD
- IF $DATA(BNIGQUIT)
- QUIT
- +13 IF $GET(BNIGSPAG)
- WRITE !!,"SUB-TOTAL for ",BNIGSORV," ",BNIGSRTR,": ",BNIGSCNT
- IF BNIGCTYP="S"
- IF (BNIGPTVS="R")
- WRITE !,?10,$EXTRACT(BNIGSRTR,1,30),?45,$JUSTIFY(BNIGSCNT,8)
- +14 IF BNIGCTYP="S"
- WRITE !,?10,$EXTRACT(BNIGSRTR,1,30),?45,$JUSTIFY(BNIGSCNT,8)
- +15 QUIT
- PRINT ;
- +1 SET BNIGSCNT=BNIGSCNT+1
- IF BNIGCTYP="S"
- QUIT
- +2 KILL ^XTMP("BNIGLINE",$JOB)
- SET ^XTMP("BNIGLINE",$JOB,1)=""
- +3 IF $Y>(BNIIOSL-5)
- DO HEAD
- IF $DATA(BNIGQUIT)
- QUIT
- +4 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
- +5 IF '$PIECE(^BNIGRI(BNIGCRIT,0),U,8)
- DO SINGLE
- QUIT
- +6 DO MULT
- +7 QUIT
- End DoDot:1
- +8 SET BNIGX=0
- FOR
- SET BNIGX=$ORDER(^XTMP("BNIGLINE",$JOB,BNIGX))
- IF BNIGX'=+BNIGX!($DATA(BNIGQUIT))
- QUIT
- Begin DoDot:1
- +9 IF $Y>(BNIIOSL-4)
- DO HEAD
- IF $DATA(BNIGQUIT)
- QUIT
- +10 WRITE !,^XTMP("BNIGLINE",$JOB,BNIGX)
- End DoDot:1
- +11 QUIT
- SINGLE ;process single valued item
- +1 KILL BNIGPRNT
- +2 SET BNIGX=0
- +3 IF $DATA(^BNIGRI(BNIGCRIT,3))
- XECUTE ^(3)
- +4 SET BNIGLENG=$PIECE(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,2)
- SET BNIGPRNT=$EXTRACT(BNIGPRNT,1,BNIGLENG)
- Begin DoDot:1
- +5 SET J=$LENGTH(BNIGPRNT)
- SET ^XTMP("BNIGLINE",$JOB,1)=^XTMP("BNIGLINE",$JOB,1)_BNIGPRNT
- SET K=$PIECE(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,2)+1
- FOR I=J:1:K
- SET ^XTMP("BNIGLINE",$JOB,1)=^XTMP("BNIGLINE",$JOB,1)_" "
- +6 SET X=1
- FOR
- SET X=$ORDER(^XTMP("BNIGLINE",$JOB,X))
- IF X'=+X
- QUIT
- IF $LENGTH(^XTMP("BNIGLINE",$JOB,X))<$LENGTH(^XTMP("BNIGLINE",$JOB,1))
- SET K=$LENGTH(^XTMP("BNIGLINE",$JOB,X))+1
- SET J=$LENGTH(^XTMP("BNIGLINE",$JOB,1))
- FOR I=K:1:J
- SET ^XTMP("BNIGLINE",$JOB,X)=^XTMP("BNIGLINE",$JOB,X)_" "
- End DoDot:1
- +7 QUIT
- MULT ;
- +1 KILL BNIGPRNT,BNIGPRNM,BNIGY
- SET (BNIGX,BNIGPCNT)=0
- +2 IF $DATA(^BNIGRI(BNIGCRIT,3))
- XECUTE ^(3)
- +3 IF '$DATA(BNIGPRNM)
- SET BNIGPRNT="--"
- Begin DoDot:1
- +4 SET BNIGLENG=$PIECE(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,2)
- SET BNIGPRNT=$EXTRACT(BNIGPRNT,1,BNIGLENG)
- Begin DoDot:2
- +5 SET J=$LENGTH(BNIGPRNT)
- SET ^XTMP("BNIGLINE",$JOB,1)=^XTMP("BNIGLINE",$JOB,1)_BNIGPRNT
- SET K=$PIECE(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,2)+1
- FOR I=J:1:K
- SET ^XTMP("BNIGLINE",$JOB,1)=^XTMP("BNIGLINE",$JOB,1)_" "
- End DoDot:2
- End DoDot:1
- +6 SET X=0
- FOR
- SET X=$ORDER(BNIGPRNM(X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +7 IF X=1
- Begin DoDot:2
- +8 SET BNIGLENG=$PIECE(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,2)
- SET BNIGPRNT=$EXTRACT(BNIGPRNM(1),1,BNIGLENG)
- Begin DoDot:3
- +9 SET J=$LENGTH(BNIGPRNT)
- SET ^XTMP("BNIGLINE",$JOB,1)=^XTMP("BNIGLINE",$JOB,1)_BNIGPRNT
- SET K=$PIECE(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,2)+1
- FOR I=J:1:K
- SET ^XTMP("BNIGLINE",$JOB,1)=^XTMP("BNIGLINE",$JOB,1)_" "
- End DoDot:3
- End DoDot:2
- QUIT
- +10 SET BNIGLENG=$PIECE(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,2)
- SET BNIGPRNT=$EXTRACT(BNIGPRNM(X),1,BNIGLENG)
- Begin DoDot:2
- +11 IF '$DATA(^XTMP("BNIGLINE",$JOB,X))
- SET ^XTMP("BNIGLINE",$JOB,X)=""
- SET K=$PIECE(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,2)+1
- SET $PIECE(^XTMP("BNIGLINE",$JOB,X)," ",($LENGTH(^XTMP("BNIGLINE",$JOB,1))-K))=""
- +12 SET J=$LENGTH(BNIGPRNT)
- SET ^XTMP("BNIGLINE",$JOB,X)=^XTMP("BNIGLINE",$JOB,X)_BNIGPRNT
- SET K=$PIECE(^BNIRTMP(BNIGRPT,12,BNIGI,0),U,2)+1
- FOR I=J:1:K
- SET ^XTMP("BNIGLINE",$JOB,X)=^XTMP("BNIGLINE",$JOB,X)_" "
- End DoDot:2
- End DoDot:1
- +13 SET X=1
- FOR
- SET X=$ORDER(^XTMP("BNIGLINE",$JOB,X))
- IF X'=+X
- QUIT
- IF $LENGTH(^XTMP("BNIGLINE",$JOB,X))<$LENGTH(^XTMP("BNIGLINE",$JOB,1))
- SET K=$LENGTH(^XTMP("BNIGLINE",$JOB,X))+1
- SET J=$LENGTH(^XTMP("BNIGLINE",$JOB,1))
- FOR I=K:1:J
- SET ^XTMP("BNIGLINE",$JOB,X)=^XTMP("BNIGLINE",$JOB,X)_" "
- +14 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
- HEAD ;ENTRY POINT
- +1 DO HEAD^BNIGVLP2
- +2 QUIT
