Routine: BCHRP1

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

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

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

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

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)

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

HEADER ;

 D HEADER^BCHRP11

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

HEADER    ;

 +1        DO HEADER^BCHRP11

 +2        QUIT

BCHRP1.m