BCHRP1 ; IHS/CMI/LAB - DETAILED/BRIEF LISTING OF RECORDS, REPORT 1 ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;IHS/CMI/LAB - Y2K
;IHS/CMI/LAB - tmp to xtmp
;
;
BDRL ;type of report
W !!?5,"Report Print Selection."
S DIR(0)="S^D:Detailed (132 column print);B:Brief (80 column print)",DIR("A")="Type of Report to Print",DIR("B")="B" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) S BCHQUIT=1 Q
S BCHRTYPE=Y
Q
PRINT ;EP
S BCHCW=$S(BCHRTYPE="B":80,1:132)
D COVPAGE^BCHRPTCP
I '$D(^XTMP("BCHRPT",BCHJOB,BCHBTH,"RECORDS")) G DONE
S (BCHRSRT,BCHFRST)="",(BCHPG,BCHRCNT)=0 K BCHQUIT
F S BCHRSRT=$O(^XTMP("BCHRPT",BCHJOB,BCHBTH,"RECORDS",BCHRSRT)) Q:BCHRSRT=""!($D(BCHQUIT)) D PRINT1
G:$D(BCHQUIT) DONE
I $Y>(IOSL-6) D HEADER G:$D(BCHQUIT) DONE
DONE ;
D DONE^BCHUTIL1,XIT^BCHRPTU
K ^XTMP("BCHRPT",BCHJOB,BCHBT)
K BCHBT,BCHBTH,BCHJOB,BCHET
Q
PRINT1 ;
;get readable sort variable
S BCHSRTR="<NONE AVAILABLE>",BCHR=$O(^XTMP("BCHRPT",BCHJOB,BCHBTH,"RECORDS",BCHRSRT,"")) I BCHR]"" S BCHCRIT=BCHSORT D
.S BCHR0=^BCHR(BCHR,0),DFN=$P(BCHR0,U,4) X:$D(^BCHSORT(BCHSORT,3)) ^BCHSORT(BCHSORT,3)
.Q
S (BCHSCNT,BCHR)=0 I $G(BCHSPAG)!($D(BCHFRST)) D HEADER Q:$D(BCHQUIT)
K BCHFRST
F S BCHR=$O(^XTMP("BCHRPT",BCHJOB,BCHBTH,"RECORDS",BCHRSRT,BCHR)) Q:BCHR=""!($D(BCHQUIT)) S BCHR0=^BCHR(BCHR,0) D @("PRINT"_BCHRTYPE)
I $Y>(IOSL-3) D HEADER Q:$D(BCHQUIT)
W:$G(BCHSPAG) !!!,"SUB-TOTAL for ",BCHSORV," ",BCHRSRT,": ",BCHSCNT
Q
PRINTB ;
S:$G(BCHSPAG) BCHSCNT=BCHSCNT+1
I $Y>(IOSL-6) D HEADER Q:$D(BCHQUIT)
S BCHRCNT=BCHRCNT+1
;begin Y2K - modified several lines to fit in 4 digit year
W !,$E($P(BCHR0,U),4,5),"/",$E($P(BCHR0,U),6,7),"/",(1700+($E($P(BCHR0,U),1,3))) S X=$P(BCHR0,U,2) ;I X]"" W ?11,$P(^BCHTPROG(X,0),U,5) ;Y2000
W ?11,$$PPINI^BCHUTIL(BCHR) ;Y2000
W ?15,$S($P(BCHR0,U,4)]"":$E($P(^DPT($P(BCHR0,U,4),0),U),1,20),$G(^BCHR(BCHR,11))]"":$E($P(^BCHR(BCHR,11),U),1,20),1:" <none>") ;Y2000
S BCHACTL=$P(BCHR0,U,6) I BCHACTL]"" S BCHACTL=$E($P(^BCHTACTL(BCHACTL,0),U),1,5) ;Y2000
S BCHSFAC=$P(BCHR0,U,5) I BCHSFAC]"" S BCHSFAC=$E($P(^AUTTLOC(BCHSFAC,0),U,2),1,5) ;Y2000
I BCHSFAC="" S BCHSFAC=BCHACTL
W ?38,BCHSFAC
W ?44,$P(BCHR0,U,11)
;end Y2K
I '$D(^BCHRPROB("AD",BCHR)) W ?51," --"
E S BCHP=0,BCHC=0 F S BCHP=$O(^BCHRPROB("AD",BCHR,BCHP)) Q:BCHP'=+BCHP S BCHPREC=^BCHRPROB(BCHP,0) D GETPROB W:BCHC ! W ?49,BCHX S BCHC=BCHC+1
Q
;
PRINTD ;detailed print
S:$G(BCHSPAG) BCHSCNT=BCHSCNT+1
I $Y>(IOSL-6) D HEADER Q:$D(BCHQUIT)
S BCHRCNT=BCHRCNT+1
;begin Y2K - reformat for 4 digit year
W !,$E($P(BCHR0,U),4,5),"/",$E($P(BCHR0,U),6,7),"/",(1700+($E($P(BCHR0,U),1,3))) S X=$P(BCHR0,U,2) ;I X]"" W ?11,$P(^BCHTPROG(X,0),U,5) ;Y2000
W ?11,$$PPINI^BCHUTIL(BCHR) ;Y2000
W ?15,$S($P(BCHR0,U,4)]"":$E($P(^DPT($P(BCHR0,U,4),0),U),1,20),$G(^BCHR(BCHR,11))]"":$E($P(^BCHR(BCHR,11),U),1,20),1:" <none>") ;Y2000
S BCHACTL=$P(BCHR0,U,6) I BCHACTL]"" S BCHACTL=$E($P(^BCHTACTL(BCHACTL,0),U),1,5) ;Y2000
S BCHSFAC=$P(BCHR0,U,5) I BCHSFAC]"" S BCHSFAC=$E($P(^AUTTLOC(BCHSFAC,0),U,2),1,5) ;Y2000
I BCHSFAC="" S BCHSFAC=BCHACTL
W ?38,BCHSFAC
W ?43,$P(BCHR0,U,11)
;end Y2K
I '$D(^BCHRPROB("AD",BCHR)) W ?51," --"
E S BCHP=0,BCHC=0 F S BCHP=$O(^BCHRPROB("AD",BCHR,BCHP)) Q:BCHP'=+BCHP S BCHPREC=^BCHRPROB(BCHP,0) D GETPROB W:BCHC ! W ?49,BCHX S BCHC=BCHC+1
;S X=$P(BCHR0,U,7) I X]"" W ?86,$E($P(^BCHTREF(X,0),U),1,7)
;S X=$P(BCHR0,U,8) I X]"" W ?96,$E($P(^BCHTREF(X,0),U),1,7)
;table both and print 1,2,3,etc
KILL BCHREFB,BCHREFT,C
S X=0,C=0 F S X=$O(^BCHR(BCHR,41,X)) Q:X'=+X S C=C+1,BCHREFB(C)=$P(^BCHTREF($P(^BCHR(BCHR,41,X,0),U),0),U,1)
S X=0,C=0 F S X=$O(^BCHR(BCHR,42,X)) Q:X'=+X S C=C+1,BCHREFT(C)=$P(^BCHTREF($P(^BCHR(BCHR,42,X,0),U),0),U,1)
F X=1:1:20 I $D(BCHREFB(X))!($D(BCHREFT(X))) D
.I X>1 W !
.W ?86,$E($G(BCHREFB(X)),1,7),?96,$E($G(BCHREFT(X)),1,7)
W ?105,$P(BCHR0,U,9)
W ?110,$P(BCHR0,U,11)
W ?116,$P(BCHR0,U,12)
;
Q
GETPROB ;
S BCHX=""
S X=$P(^BCHTPROB($P(BCHPREC,U),0),U,2)_" "
S X=X_$S($P(BCHPREC,U,4)]"":$P(^BCHTSERV($P(BCHPREC,U,4),0),U,3),1:" ")_" "
S X=X_$J($P(BCHPREC,U,5),3)_" "
S N=$P(BCHPREC,U,6) I N,$D(^AUTNPOV(N,0)) S N=$P(^AUTNPOV(N,0),U)
S X=X_$S(N]"":$E(N,1,20),1:" ")
S BCHX=BCHX_X
Q
D HEADER^BCHRP11
Q
BCHRP1 ; IHS/CMI/LAB - DETAILED/BRIEF LISTING OF RECORDS, REPORT 1 ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;IHS/CMI/LAB - Y2K
+3 ;IHS/CMI/LAB - tmp to xtmp
+4 ;
+5 ;
BDRL ;type of report
+1 WRITE !!?5,"Report Print Selection."
+2 SET DIR(0)="S^D:Detailed (132 column print);B:Brief (80 column print)"
SET DIR("A")="Type of Report to Print"
SET DIR("B")="B"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DIRUT)
SET BCHQUIT=1
QUIT
+4 SET BCHRTYPE=Y
+5 QUIT
PRINT ;EP
+1 SET BCHCW=$SELECT(BCHRTYPE="B":80,1:132)
+2 DO COVPAGE^BCHRPTCP
+3 IF '$DATA(^XTMP("BCHRPT",BCHJOB,BCHBTH,"RECORDS"))
GOTO DONE
+4 SET (BCHRSRT,BCHFRST)=""
SET (BCHPG,BCHRCNT)=0
KILL BCHQUIT
+5 FOR
SET BCHRSRT=$ORDER(^XTMP("BCHRPT",BCHJOB,BCHBTH,"RECORDS",BCHRSRT))
IF BCHRSRT=""!($DATA(BCHQUIT))
QUIT
DO PRINT1
+6 IF $DATA(BCHQUIT)
GOTO DONE
+7 IF $Y>(IOSL-6)
DO HEADER
IF $DATA(BCHQUIT)
GOTO DONE
DONE ;
+1 DO DONE^BCHUTIL1
DO XIT^BCHRPTU
+2 KILL ^XTMP("BCHRPT",BCHJOB,BCHBT)
+3 KILL BCHBT,BCHBTH,BCHJOB,BCHET
+4 QUIT
PRINT1 ;
+1 ;get readable sort variable
+2 SET BCHSRTR="<NONE AVAILABLE>"
SET BCHR=$ORDER(^XTMP("BCHRPT",BCHJOB,BCHBTH,"RECORDS",BCHRSRT,""))
IF BCHR]""
SET BCHCRIT=BCHSORT
Begin DoDot:1
+3 SET BCHR0=^BCHR(BCHR,0)
SET DFN=$PIECE(BCHR0,U,4)
IF $DATA(^BCHSORT(BCHSORT,3))
XECUTE ^BCHSORT(BCHSORT,3)
+4 QUIT
End DoDot:1
+5 SET (BCHSCNT,BCHR)=0
IF $GET(BCHSPAG)!($DATA(BCHFRST))
DO HEADER
IF $DATA(BCHQUIT)
QUIT
+6 KILL BCHFRST
+7 FOR
SET BCHR=$ORDER(^XTMP("BCHRPT",BCHJOB,BCHBTH,"RECORDS",BCHRSRT,BCHR))
IF BCHR=""!($DATA(BCHQUIT))
QUIT
SET BCHR0=^BCHR(BCHR,0)
DO @("PRINT"_BCHRTYPE)
+8 IF $Y>(IOSL-3)
DO HEADER
IF $DATA(BCHQUIT)
QUIT
+9 IF $GET(BCHSPAG)
WRITE !!!,"SUB-TOTAL for ",BCHSORV," ",BCHRSRT,": ",BCHSCNT
+10 QUIT
PRINTB ;
+1 IF $GET(BCHSPAG)
SET BCHSCNT=BCHSCNT+1
+2 IF $Y>(IOSL-6)
DO HEADER
IF $DATA(BCHQUIT)
QUIT
+3 SET BCHRCNT=BCHRCNT+1
+4 ;begin Y2K - modified several lines to fit in 4 digit year
+5 ;I X]"" W ?11,$P(^BCHTPROG(X,0),U,5) ;Y2000
WRITE !,$EXTRACT($PIECE(BCHR0,U),4,5),"/",$EXTRACT($PIECE(BCHR0,U),6,7),"/",(1700+($EXTRACT($PIECE(BCHR0,U),1,3)))
SET X=$PIECE(BCHR0,U,2)
+6 ;Y2000
WRITE ?11,$$PPINI^BCHUTIL(BCHR)
+7 ;Y2000
WRITE ?15,$SELECT($PIECE(BCHR0,U,4)]"":$EXTRACT($PIECE(^DPT($PIECE(BCHR0,U,4),0),U),1,20),$GET(^BCHR(BCHR,11))]"":$EXTRACT($PIECE(^BCHR(BCHR,11),U),1,20),1:" <none>")
+8 ;Y2000
SET BCHACTL=$PIECE(BCHR0,U,6)
IF BCHACTL]""
SET BCHACTL=$EXTRACT($PIECE(^BCHTACTL(BCHACTL,0),U),1,5)
+9 ;Y2000
SET BCHSFAC=$PIECE(BCHR0,U,5)
IF BCHSFAC]""
SET BCHSFAC=$EXTRACT($PIECE(^AUTTLOC(BCHSFAC,0),U,2),1,5)
+10 IF BCHSFAC=""
SET BCHSFAC=BCHACTL
+11 WRITE ?38,BCHSFAC
+12 WRITE ?44,$PIECE(BCHR0,U,11)
+13 ;end Y2K
+14 IF '$DATA(^BCHRPROB("AD",BCHR))
WRITE ?51," --"
+15 IF '$TEST
SET BCHP=0
SET BCHC=0
FOR
SET BCHP=$ORDER(^BCHRPROB("AD",BCHR,BCHP))
IF BCHP'=+BCHP
QUIT
SET BCHPREC=^BCHRPROB(BCHP,0)
DO GETPROB
IF BCHC
WRITE !
WRITE ?49,BCHX
SET BCHC=BCHC+1
+16 QUIT
+17 ;
PRINTD ;detailed print
+1 IF $GET(BCHSPAG)
SET BCHSCNT=BCHSCNT+1
+2 IF $Y>(IOSL-6)
DO HEADER
IF $DATA(BCHQUIT)
QUIT
+3 SET BCHRCNT=BCHRCNT+1
+4 ;begin Y2K - reformat for 4 digit year
+5 ;I X]"" W ?11,$P(^BCHTPROG(X,0),U,5) ;Y2000
WRITE !,$EXTRACT($PIECE(BCHR0,U),4,5),"/",$EXTRACT($PIECE(BCHR0,U),6,7),"/",(1700+($EXTRACT($PIECE(BCHR0,U),1,3)))
SET X=$PIECE(BCHR0,U,2)
+6 ;Y2000
WRITE ?11,$$PPINI^BCHUTIL(BCHR)
+7 ;Y2000
WRITE ?15,$SELECT($PIECE(BCHR0,U,4)]"":$EXTRACT($PIECE(^DPT($PIECE(BCHR0,U,4),0),U),1,20),$GET(^BCHR(BCHR,11))]"":$EXTRACT($PIECE(^BCHR(BCHR,11),U),1,20),1:" <none>")
+8 ;Y2000
SET BCHACTL=$PIECE(BCHR0,U,6)
IF BCHACTL]""
SET BCHACTL=$EXTRACT($PIECE(^BCHTACTL(BCHACTL,0),U),1,5)
+9 ;Y2000
SET BCHSFAC=$PIECE(BCHR0,U,5)
IF BCHSFAC]""
SET BCHSFAC=$EXTRACT($PIECE(^AUTTLOC(BCHSFAC,0),U,2),1,5)
+10 IF BCHSFAC=""
SET BCHSFAC=BCHACTL
+11 WRITE ?38,BCHSFAC
+12 WRITE ?43,$PIECE(BCHR0,U,11)
+13 ;end Y2K
+14 IF '$DATA(^BCHRPROB("AD",BCHR))
WRITE ?51," --"
+15 IF '$TEST
SET BCHP=0
SET BCHC=0
FOR
SET BCHP=$ORDER(^BCHRPROB("AD",BCHR,BCHP))
IF BCHP'=+BCHP
QUIT
SET BCHPREC=^BCHRPROB(BCHP,0)
DO GETPROB
IF BCHC
WRITE !
WRITE ?49,BCHX
SET BCHC=BCHC+1
+16 ;S X=$P(BCHR0,U,7) I X]"" W ?86,$E($P(^BCHTREF(X,0),U),1,7)
+17 ;S X=$P(BCHR0,U,8) I X]"" W ?96,$E($P(^BCHTREF(X,0),U),1,7)
+18 ;table both and print 1,2,3,etc
+19 KILL BCHREFB,BCHREFT,C
+20 SET X=0
SET C=0
FOR
SET X=$ORDER(^BCHR(BCHR,41,X))
IF X'=+X
QUIT
SET C=C+1
SET BCHREFB(C)=$PIECE(^BCHTREF($PIECE(^BCHR(BCHR,41,X,0),U),0),U,1)
+21 SET X=0
SET C=0
FOR
SET X=$ORDER(^BCHR(BCHR,42,X))
IF X'=+X
QUIT
SET C=C+1
SET BCHREFT(C)=$PIECE(^BCHTREF($PIECE(^BCHR(BCHR,42,X,0),U),0),U,1)
+22 FOR X=1:1:20
IF $DATA(BCHREFB(X))!($DATA(BCHREFT(X)))
Begin DoDot:1
+23 IF X>1
WRITE !
+24 WRITE ?86,$EXTRACT($GET(BCHREFB(X)),1,7),?96,$EXTRACT($GET(BCHREFT(X)),1,7)
End DoDot:1
+25 WRITE ?105,$PIECE(BCHR0,U,9)
+26 WRITE ?110,$PIECE(BCHR0,U,11)
+27 WRITE ?116,$PIECE(BCHR0,U,12)
+28 ;
+29 QUIT
GETPROB ;
+1 SET BCHX=""
+2 SET X=$PIECE(^BCHTPROB($PIECE(BCHPREC,U),0),U,2)_" "
+3 SET X=X_$SELECT($PIECE(BCHPREC,U,4)]"":$PIECE(^BCHTSERV($PIECE(BCHPREC,U,4),0),U,3),1:" ")_" "
+4 SET X=X_$JUSTIFY($PIECE(BCHPREC,U,5),3)_" "
+5 SET N=$PIECE(BCHPREC,U,6)
IF N
IF $DATA(^AUTNPOV(N,0))
SET N=$PIECE(^AUTNPOV(N,0),U)
+6 SET X=X_$SELECT(N]"":$EXTRACT(N,1,20),1:" ")
+7 SET BCHX=BCHX_X
+8 QUIT
+1 DO HEADER^BCHRP11
+2 QUIT
