Routine: PXRRWLPF

PXRRWLPF ;ISL/PKR - Printing functions for the encounter summary report. ;8/26/97

 ;;1.0;PCE PATIENT CARE ENCOUNTER;**20**;Aug 12, 1996

 ;=======================================================================

GTOTAL ;Add the facility totals to the grand totals.

 S GTCON=GTCON+FTCON

 S GTEST=GTEST+FTEST

 S GTINP=GTINP+FTINP

 S GTNEW=GTNEW+FTNEW

 S GTNOEM=GTNOEM+FTNOEM

 S GTNOCPT=GTNOCPT+FTNOCPT

 S GTOP=GTOP+FTOP

 S GTOTH=GTOTH+FTOTH

 S GTSSN=GTSSN+FTSSN

 S GTTENC=GTTENC+FTTENC

 S GTTVIS=GTTVIS+FTTVIS

 S GTCP=GTCP+FTCP

 S GTSCH=GTSCH+FTSCH

 S GTTEN=GTTEN+FTTEN

 S GTUNS=GTUNS+FTUNS

 ;=======================================================================

HEAD(NEWPAGE) ;If necessary, write the header.

 I NEWPAGE D PAGE

 E  I $Y>(IOSL-BMARG) D PAGE

 I DONE Q

 I HEAD D

 . N IC

 . I $Y>(IOSL-BMARG-7) D PAGE^PXRRGPRT

 . I DONE G NP

 . W !!,"Facility: ",FACPNAME

 . W !,?C1HS,BY

 . W !,?C3HS,"       E&M CATEGORIES      NON   NO     TOT   TOT  UNIQ   IN    OUT"

 . W !,?C2HS,"PCE:",?C3HS,"   NEW   EST   CON   OTH   E&M   CPT    ENC   VIS   SSN   PAT   PAT"

 . D WDIVIDER(C2HS)

 . W !,?C2HS,"SCH:",?C3HS,"   C&P 10-10   SCH   UNS"

 . W ! F IC=1:1:80 W "="

NP . S HEAD=0

 ;=======================================================================

PAGE ;form feed to new page

 I ($E(IOST)="C")&(IO=IO(0)) D

 . S DIR(0)="E"

 . W !

 . D ^DIR K DIR

 I $D(DIROUT)!$D(DUOUT)!($D(DTOUT)) S DONE=1 Q

 W:$D(IOF) @IOF

 S PAGE=PAGE+1

 D HDR^PXRRGPRT(PAGE)

 S HEAD=1

 ;=======================================================================

RETSOC(FILE,FIELD,SOC) ;Return the set of codes for field FIELD of

 ;file FILE in SOC.

 N CODE,IC,TEMP,TSOC

 D HELP^DIE(FILE,"",FIELD,"S","TSOC")

 ;TSOC will have the code followed by a number of spaces and then

 ;the code text.

 F IC=2:1:TSOC("DIHELP") D

 . S TEMP=TSOC("DIHELP",IC)

 . S CODE=$P(TEMP," ",1)

 . S $P(TEMP," ",1)=CODE_U

 . S TEMP=$$STRREP^PXRRUTIL(TEMP,"  ","")

 . S SOC(CODE)=$P(TEMP,U,2)

 ;=======================================================================

WDIVIDER(START) ;Write the header divider.

 N IC

 W !,?START F IC=START+1:1:80 W "-"

 ;=======================================================================

WFACTOT ;Write the facility totals.

 I $Y>(IOSL-BMARG-5) D HEAD(1)

 W !!,?C1HS,FACPNAME," (totals)"

 W !,?C2HS,"PCE:"

 W ?C3S

 W $J(FTNEW,6)

 W $J(FTEST,6)

 W $J(FTCON,6)

 W $J(FTOTH,6)

 W $J(FTNOEM,6)

 W $J(FTNOCPT,6)

 W $J(FTTENC,7)

 W $J(FTTVIS,6)

 W $J(FTSSN,6)

 W $J(FTINP,6)

 W $J(FTOP,6)

 ;Write the appointment info.

 D WDIVIDER(C2HS)

 W !,?C2HS,"SCH:"

 W ?C3HS,$J(FTCP,6)

 W $J(FTTEN,6)

 W $J(FTSCH,6)

 W $J(FTUNS,6)

 ;=======================================================================

WGTOTAL ;Write the grand totals.

 I $Y>(IOSL-BMARG-5) D HEAD(1)

 W !!,?C1HS,"GRAND TOTALS"

 W !,?C2HS,"PCE:"

 W ?C3S

 W $J(GTNEW,6)

 W $J(GTEST,6)

 W $J(GTCON,6)

 W $J(GTOTH,6)

 W $J(GTNOEM,6)

 W $J(GTNOCPT,6)

 W $J(GTTENC,7)

 W $J(GTTVIS,6)

 W $J(GTSSN,6)

 W $J(GTINP,6)

 W $J(GTOP,6)

 ;Write the appointment info.

 D WDIVIDER(C2HS)

 W !,?C2HS,"SCH:"

 W ?C3HS,$J(GTCP,6)

 W $J(GTTEN,6)

 W $J(GTSCH,6)

 W $J(GTUNS,6)

PXRRWLPF  ;ISL/PKR - Printing functions for the encounter summary report. ;8/26/97

 +1       ;;1.0;PCE PATIENT CARE ENCOUNTER;**20**;Aug 12, 1996

 +2       ;

 +3       ;=======================================================================

GTOTAL    ;Add the facility totals to the grand totals.

 +1        SET GTCON=GTCON+FTCON

 +2        SET GTEST=GTEST+FTEST

 +3        SET GTINP=GTINP+FTINP

 +4        SET GTNEW=GTNEW+FTNEW

 +5        SET GTNOEM=GTNOEM+FTNOEM

 +6        SET GTNOCPT=GTNOCPT+FTNOCPT

 +7        SET GTOP=GTOP+FTOP

 +8        SET GTOTH=GTOTH+FTOTH

 +9        SET GTSSN=GTSSN+FTSSN

 +10       SET GTTENC=GTTENC+FTTENC

 +11       SET GTTVIS=GTTVIS+FTTVIS

 +12       SET GTCP=GTCP+FTCP

 +13       SET GTSCH=GTSCH+FTSCH

 +14       SET GTTEN=GTTEN+FTTEN

 +15       SET GTUNS=GTUNS+FTUNS

 +16       QUIT

 +17      ;

 +18      ;=======================================================================

HEAD(NEWPAGE) ;If necessary, write the header.

 +1        IF NEWPAGE

               DO PAGE

 +2       IF '$TEST

               IF $Y>(IOSL-BMARG)

                   DO PAGE

 +3        IF DONE

               QUIT

 +4        IF HEAD

               Begin DoDot:1

 +5                NEW IC

 +6                IF $Y>(IOSL-BMARG-7)

                       DO PAGE^PXRRGPRT

 +7                IF DONE

                       GOTO NP

 +8                WRITE !!,"Facility: ",FACPNAME

 +9                WRITE !,?C1HS,BY

 +10               WRITE !,?C3HS,"       E&M CATEGORIES      NON   NO     TOT   TOT  UNIQ   IN    OUT"

 +11               WRITE !,?C2HS,"PCE:",?C3HS,"   NEW   EST   CON   OTH   E&M   CPT    ENC   VIS   SSN   PAT   PAT"

 +12               DO WDIVIDER(C2HS)

 +13               WRITE !,?C2HS,"SCH:",?C3HS,"   C&P 10-10   SCH   UNS"

 +14               WRITE !

                   FOR IC=1:1:80

                       WRITE "="

NP                 SET HEAD=0

               End DoDot:1

 +1        QUIT

 +2       ;

 +3       ;=======================================================================

PAGE      ;form feed to new page

 +1        IF ($EXTRACT(IOST)="C")&(IO=IO(0))

               Begin DoDot:1

 +2                SET DIR(0)="E"

 +3                WRITE !

 +4                DO ^DIR

                   KILL DIR

               End DoDot:1

 +5        IF $DATA(DIROUT)!$DATA(DUOUT)!($DATA(DTOUT))

               SET DONE=1

               QUIT

 +6        IF $DATA(IOF)

               WRITE @IOF

 +7        SET PAGE=PAGE+1

 +8        DO HDR^PXRRGPRT(PAGE)

 +9        SET HEAD=1

 +10       QUIT

 +11      ;

 +12      ;=======================================================================

RETSOC(FILE,FIELD,SOC) ;Return the set of codes for field FIELD of

 +1       ;file FILE in SOC.

 +2        NEW CODE,IC,TEMP,TSOC

 +3        DO HELP^DIE(FILE,"",FIELD,"S","TSOC")

 +4       ;TSOC will have the code followed by a number of spaces and then

 +5       ;the code text.

 +6        FOR IC=2:1:TSOC("DIHELP")

               Begin DoDot:1

 +7                SET TEMP=TSOC("DIHELP",IC)

 +8                SET CODE=$PIECE(TEMP," ",1)

 +9                SET $PIECE(TEMP," ",1)=CODE_U

 +10               SET TEMP=$$STRREP^PXRRUTIL(TEMP,"  ","")

 +11               SET SOC(CODE)=$PIECE(TEMP,U,2)

               End DoDot:1

 +12       QUIT

 +13      ;

 +14      ;=======================================================================

WDIVIDER(START) ;Write the header divider.

 +1        NEW IC

 +2        WRITE !,?START

           FOR IC=START+1:1:80

               WRITE "-"

 +3        QUIT

 +4       ;

 +5       ;=======================================================================

WFACTOT   ;Write the facility totals.

 +1        IF $Y>(IOSL-BMARG-5)

               DO HEAD(1)

 +2        WRITE !!,?C1HS,FACPNAME," (totals)"

 +3        WRITE !,?C2HS,"PCE:"

 +4        WRITE ?C3S

 +5        WRITE $JUSTIFY(FTNEW,6)

 +6        WRITE $JUSTIFY(FTEST,6)

 +7        WRITE $JUSTIFY(FTCON,6)

 +8        WRITE $JUSTIFY(FTOTH,6)

 +9        WRITE $JUSTIFY(FTNOEM,6)

 +10       WRITE $JUSTIFY(FTNOCPT,6)

 +11       WRITE $JUSTIFY(FTTENC,7)

 +12       WRITE $JUSTIFY(FTTVIS,6)

 +13       WRITE $JUSTIFY(FTSSN,6)

 +14       WRITE $JUSTIFY(FTINP,6)

 +15       WRITE $JUSTIFY(FTOP,6)

 +16      ;

 +17      ;Write the appointment info.

 +18       DO WDIVIDER(C2HS)

 +19       WRITE !,?C2HS,"SCH:"

 +20       WRITE ?C3HS,$JUSTIFY(FTCP,6)

 +21       WRITE $JUSTIFY(FTTEN,6)

 +22       WRITE $JUSTIFY(FTSCH,6)

 +23       WRITE $JUSTIFY(FTUNS,6)

 +24       QUIT

 +25      ;

 +26      ;=======================================================================

WGTOTAL   ;Write the grand totals.

 +1        IF $Y>(IOSL-BMARG-5)

               DO HEAD(1)

 +2        WRITE !!,?C1HS,"GRAND TOTALS"

 +3        WRITE !,?C2HS,"PCE:"

 +4        WRITE ?C3S

 +5        WRITE $JUSTIFY(GTNEW,6)

 +6        WRITE $JUSTIFY(GTEST,6)

 +7        WRITE $JUSTIFY(GTCON,6)

 +8        WRITE $JUSTIFY(GTOTH,6)

 +9        WRITE $JUSTIFY(GTNOEM,6)

 +10       WRITE $JUSTIFY(GTNOCPT,6)

 +11       WRITE $JUSTIFY(GTTENC,7)

 +12       WRITE $JUSTIFY(GTTVIS,6)

 +13       WRITE $JUSTIFY(GTSSN,6)

 +14       WRITE $JUSTIFY(GTINP,6)

 +15       WRITE $JUSTIFY(GTOP,6)

 +16      ;

 +17      ;Write the appointment info.

 +18       DO WDIVIDER(C2HS)

 +19       WRITE !,?C2HS,"SCH:"

 +20       WRITE ?C3HS,$JUSTIFY(GTCP,6)

 +21       WRITE $JUSTIFY(GTTEN,6)

 +22       WRITE $JUSTIFY(GTSCH,6)

 +23       WRITE $JUSTIFY(GTUNS,6)

 +24       QUIT

 +25      ;

PXRRWLPF.m