PXRRFDP.m

PXRRFDP ;ISL/PKR - Final sort and print of frequency of diagnosis report. ;05/17/2018

 ;;1.0;PCE PATIENT CARE ENCOUNTER;**3,10,12,18,31,121,199,211**;Aug 12, 1996;Build 454

 ;

PRINT ;

 N ANS,BD,BMARG,C1E,C1S,C2E,C2S,C3E,C3S,C1HS,C2HS,C3HS,CMAX,INDENT,MID

 N DCSTR,HEAD,LEN,NUM,PAGE

 N BYLOC,BYPC,BYPRV,DCIEN,DOCOUNT,DONE,DTOT,ED,ETOT,FOUND,HLOC,IC,ICD9IEN

 N FACILITY,FACPNAME,IC,ICDDATA,ICDDATE,IMPDATE,INFOTYPE,LOCPNAM,NEWPAGE,PCLASS,PRV

 N RATIO,STOIND,TEMP,TOTAL,TOTSTR,VACODE,ICDSTR

 ;

 ;Allow the task to be cleaned up upon successful completion.

 S ZTREQ="@"

 ;

 U IO

 ;ICR #5679

 S IMPDATE=$$IMPDATE^LEXU("10D")

 ; When no Diagnoses found for Criteria for either ICD-9 or ICD-10, rpt Criteria

 ; and End the run.

 I (DIAGTOT=0)&(DGTOT10=0) S DOCOUNT=1 D PROCSS2 G END

 F DOCOUNT=1:1:2 D PROCESS

 G END

 ;

PROCESS ;

 I DOCOUNT=1,DIAGTOT=0 Q

 I DOCOUNT=2,DGTOT10=0 Q

PROCSS2 S ICDDATE=$S(DOCOUNT=2:IMPDATE,1:$$FMADD^XLFDT(IMPDATE,-1))

 S BMARG=2

 S INDENT=3,PAGE=1,C1S=INDENT+29

 ;

 S DONE=0

 D HDR^PXRRGPRT(PAGE)

 W !!,"Criteria for Frequency of Diagnoses Report"

 W !,?INDENT,"Encounter diagnoses:",?C1S,$P(PXRRFDDC,U,2)

 S BD=$$FMTE^XLFDT(PXRRBDT)

 S ED=$$FMTE^XLFDT(PXRREDT)

 W !,?INDENT,"Encounter date range:",?C1S,BD," through ",ED

 I PXRRECAT="" D  G MAXP

 . W !,?INDENT,"Selected encounters:",?C1S,"ALL"

 ;

 I $D(PXRRPRSC) W !,?INDENT,"Selected Providers:",?C1S,$P(PXRRPRSC,U,2)

 I $D(PXRRCS) S ANS="YES"

 E  S ANS="ALL"

 I $D(PXRRLCSC) W !,?INDENT,$P(PXRRLCSC,U,2)

 I $D(PXRRETYP) W !,?INDENT,"Encounter type:",?C1S,PXRRETYP

 ;

 I $D(PXRRDOB) D

 . I (PXRRDOBE'=DT)&(PXRRDOBS'=0) D

 .. W !,?INDENT,"Patient age range:",?C1S,PXRRMINA," to ",PXRRMAXA

 .. S BD=$$FMTE^XLFDT(PXRRDOBS),ED=$$FMTE^XLFDT(PXRRDOBE)

 .. W !,?INDENT,"Patient date of birth:",?C1S,BD," through ",ED

 . I (PXRRDOBS=0) D

 .. W !,?INDENT,"Patient age range:",?C1S,PXRRMINA," or more"

 .. S ED=$$FMTE^XLFDT(PXRRDOBE)

 .. W !,?INDENT,"Patient date of birth:",?C1S,ED," or before"

 . I (PXRRDOBE=DT) D

 .. W !,?INDENT,"Patient age range:",?C1S,"Up to ",PXRRMAXA

 .. S BD=$$FMTE^XLFDT(PXRRDOBS),ED=$$FMTE^XLFDT(DT)

 .. W !,?INDENT,"Patient date of birth:",?C1S,BD," through ",ED

 E  W !,?INDENT,"Patient age range:",?C1S,"ALL"

 ;

 I $D(PXRRRACE) D

 . N RACE

 . S RACE="race"

 . I NRACE>1 S RACE="races"

 . W !?INDENT,"Patient ",RACE,":",?C1S,$P(PXRRRACE(1),U,2)

 . F IC=2:1:NRACE W !,?C1S,$P(PXRRRACE(IC),U,2)

 E  W !?INDENT,"Patient race(s):",?C1S,"ALL"

 ;

 I $D(PXRRSEX) W !?INDENT,"Patient sex:",?C1S,$P(PXRRSEX,U,2)

 E  W !?INDENT,"Patient sex:",?C1S,"BOTH"

 ;

 I $D(PXRRSCAT) D OSCAT^PXRRGPRT(PXRRSCAT,INDENT)

 ;

 I $P($G(PXRRPRSC),U,1)="C" D PECLASS^PXRRGPRT(INDENT)

 ;

MAXP W !!,?INDENT,"Maximum number of diagnoses to be displayed: ",PXRRDMAX

 ;

 S CMAX=70

 ;

 I $D(PXRRLCSC) D

 . I PXRRLCSC["C" S PLOCNAM="Clinic Stop: "

 . I PXRRLCSC["H" S PLOCNAM="Hospital Location: "

 ;

 S FACILITY=""

NFAC S INFOTYPE="FACILITY"

 S FACILITY=$O(^XTMP(PXRRXTMP,"INFO",INFOTYPE,FACILITY))

 I +FACILITY=0 Q

 ;Mark the facility as being found.

 F IC=1:1:NFAC I $P(PXRRFAC(IC),U,1)=FACILITY D  Q

 . S $P(PXRRFAC(IC),U,4)="M"

 S FACPNAME=$P(PXRRFACN(FACILITY),U,1)_"  "_$P(PXRRFACN(FACILITY),U,2)

 ;

 ;Check for a user request to stop the task.

 I $$S^%ZTLOAD S ZTSTOP=1 D EXIT^PXRRFDD

 ;

NINFO S INFOTYPE=$O(^XTMP(PXRRXTMP,"INFO",INFOTYPE))

 I INFOTYPE="" G NFAC

 ;

 I INFOTYPE["LOC" S BYLOC=1

 E  S BYLOC=0

 I INFOTYPE["PC" S BYPC=1

 E  S BYPC=0

 I INFOTYPE["PRV" S BYPRV=1

 E  S BYPRV=0

 ;

 S PRV=""

NPRV ;

 S PRV=$O(^XTMP(PXRRXTMP,"INFO",INFOTYPE,FACILITY,PRV))

 I PRV="" G NINFO

 ;

 S VACODE=""

NVACODE ;

 S VACODE=$O(^XTMP(PXRRXTMP,"INFO",INFOTYPE,FACILITY,PRV,VACODE))

 I VACODE="" G NPRV

 ;

 S HLOC=""

NLOC S HLOC=$O(^XTMP(PXRRXTMP,"INFO",INFOTYPE,FACILITY,PRV,VACODE,HLOC))

 I HLOC="" G NVACODE

 ;

 S STOIND=^XTMP(PXRRXTMP,"INFO",INFOTYPE,FACILITY,PRV,VACODE,HLOC)

 ;

 ;If the report is by provider get a person class for the provider.

 I BYPRV D

 . S TEMP=$P(PRV,U,4)

 . I $L(TEMP)>0 S PCLASS=$$ABBRV^PXRRPECU(TEMP)

 . E  S PCLASS="Unknown"

 ;

 ;If the report is by person class get the person class.

 I BYPC D

 . S PCLASS=$$ABBRV^PXRRPECU(VACODE)

 ;

 S HEAD=1

 D HEAD(0)

 I DONE G EXIT

 S C1S=INDENT+60

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

 I DONE G EXIT

 I $P(PXRRFDDC,U,1)="P" S TEMP="Total number of Primary Diagnoses for these Encounters:"

 E  S TEMP="Total number of Diagnoses for these Encounters:"

 I $D(^XTMP(PXRRXTMP,"TOTALS","ENCTOT",STOIND)) S ETOT=^XTMP(PXRRXTMP,"TOTALS","ENCTOT",STOIND)

 E  S ETOT=0

 S TOTSTR=$S(DOCOUNT=1:"DIAGTOT",1:"DGTOT10")

 I $D(^XTMP(PXRRXTMP,"TOTALS",TOTSTR,STOIND)) S DTOT=^XTMP(PXRRXTMP,"TOTALS",TOTSTR,STOIND)

 E  S DTOT=0

 S LEN=$$MAX^XLFMTH($L(DTOT),$L(ETOT))

 W !!,?INDENT,"Total number of Encounters meeting the selection criteria:",?C1S,$J(ETOT,LEN)

 W !,?INDENT,TEMP,?C1S,$J(DTOT,LEN)

 S RATIO=$S(ETOT>0:(DTOT/ETOT),1:0)

 W !,?INDENT,"Diagnoses/Encounter ratio:",?C1S,$J(RATIO,LEN,2)

 ;

 S C1S=INDENT+8,C2E=INDENT+59

 S C1HS=INDENT+9,C2HS=INDENT+33

 S TOTAL=""

 S NUM=0,ICDSTR=$S(DOCOUNT=1:"ICD9",1:"ICD10")

NTOTICD S TOTAL=$O(^XTMP(PXRRXTMP,"PRINT",STOIND,ICDSTR,TOTAL),-1)

 I TOTAL="" G DIAGCAT

 S TEMP=TOTAL

 S ICD9IEN=""

NICD9 S ICD9IEN=$O(^XTMP(PXRRXTMP,"PRINT",STOIND,ICDSTR,TOTAL,ICD9IEN),-1)

 I ICD9IEN="" G NTOTICD

 S NUM=NUM+1

 I NUM=1 S HEAD=1

 I $Y>(IOSL-BMARG-5) S NEWPAGE=1

 E  S NEWPAGE=0

 D DHEAD(NEWPAGE)

 I DONE G EXIT

 S C3S=C3E-$L(TEMP)

 S ICDDATA=$$ICDDATA^ICDXCODE("DIAG",ICD9IEN,ICDDATE,"I")

 W !," ",$P(ICDDATA,U,2),?11,$E($P(ICDDATA,U,4),1,60),?72,$J($FN(TEMP,",",0),7)

 I NUM<PXRRDMAX G NICD9

DIAGCAT ;

 S C1S=INDENT+8,C1E=INDENT+38

 S C1HS=14

 S TOTAL=""

 S NUM=0

 S DCSTR=$S(DOCOUNT=1:"DC",1:"DC10")

NTOTDC S TOTAL=$O(^XTMP(PXRRXTMP,"PRINT",STOIND,DCSTR,TOTAL),-1)

 I TOTAL="" G NLOC

 S TEMP=TOTAL

 S DCIEN=""

NDC S DCIEN=$O(^XTMP(PXRRXTMP,"PRINT",STOIND,DCSTR,TOTAL,DCIEN),-1)

 I DCIEN="" G NTOTDC

 S NUM=NUM+1

 I NUM=1 S HEAD=1

 I $Y>(IOSL-BMARG-5) S NEWPAGE=1

 E  S NEWPAGE=0

 D DCHEAD(NEWPAGE)

 I DONE G EXIT

 S C2S=C2E-$L(TEMP)

 ;We will need a DBIA to read ICM.  Some sites have had a corrupted ICM

 ;file.  Check for this problem, if found print an error message and

 ;quit.

 I (DCIEN>0)&('$D(^ICM(DCIEN,0))) D  G EXIT

 . W !!,"CANNOT CONTINUE, File 80.3 Major Diagnostic Category is corrupted!"

 . W !,"^ICM(",DCIEN,",0) is missing."

 . W !,"Please contact customer service for help."

 I DCIEN>0 W !,?INDENT,$J(NUM,5),".",?C1S,$P(^ICM(DCIEN,0),U,1),?C2S,TEMP

 E  W !,?INDENT,$J(NUM,5),".",?C1S,"Unknown",?C2S,TEMP

 I NUM<PXRRDMAX G NDC

 ;

 ;Get the next location.

 G NLOC

END ;

 ;Check for facilities that were listed but had no encounters.

 D FACNE^PXRRGPRT(INDENT)

EXIT ;

 D EXIT^PXRRGUT

 D EOR^PXRRGUT

 Q

 ;

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

DHEAD(NEWPAGE) ;

 N DASH60 S $P(DASH60,"-",61)=""

 I NEWPAGE D PAGE^PXRRGPRT

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

 I DONE Q

 I (HEAD)&(RATIO>0) D

 . S LEN=$$MAX^XLFMTH(9,$L(TEMP))

 . S MID=C2E+3+(LEN/2)

 . S C3HS=MID-5

 . S C3E=MID+($L(TEMP)/2)

 . W !!,?INDENT,PXRRDMAX," Most Frequent ICD-",$S(DOCOUNT=1:"9",1:"10")," Diagnoses:"

 . W !," Code",?11,"Description",?72,"Freq."

 . W !," --------",?11,DASH60,?72,"-------"

 . S HEAD=0

 Q

 ;

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

DCHEAD(NEWPAGE) ;

 I NEWPAGE D PAGE^PXRRGPRT

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

 I DONE Q

 I (HEAD)&(RATIO>0) D

 . S LEN=$$MAX^XLFMTH(9,$L(TEMP))

 . S MID=C1E+3+(LEN/2)

 . S C2HS=MID-5

 . S C2E=MID+($L(TEMP)/2)

 . W !!,?INDENT,PXRRDMAX," Most Frequent ICD-",$S(DOCOUNT=1:"9",1:"10")," Diagnostic Categories:"

 . W !,?C1HS,"Diagnostic Category",?C2HS,"Frequency"

 . W !,?C1S,"------------------------------",?C2HS,"---------"

 . S HEAD=0

 Q

 ;

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

HEAD(NEWPAGE) ;

 N LEN,TEMP

 I NEWPAGE D PAGE^PXRRGPRT

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

 I DONE Q

 I HEAD D

 . W !!,"___________________________________________________________________"

 . W !,"Facility: ",FACPNAME

 . I BYLOC W !,PLOCNAM,$P(HLOC,U,1)_" (",$P(HLOC,U,3)_")"

 . I BYPRV D

 .. S TEMP="Provider: "_$P(PRV,U,1)_" ("_PCLASS_")"

 .. S LEN=$L(TEMP)

 .. I LEN>CMAX D

 ... W !,$E(TEMP,1,CMAX)

 ... W !," ",$E(TEMP,CMAX+1,LEN)

 .. E  W !,TEMP

 . I BYPC D

 .. W !,"Person Class (Occupation+Specialty+Subspecialty): "

 .. S LEN=INDENT+$L(PCLASS)

 .. I LEN>CMAX D

 ... W !,?INDENT,$E(PCLASS,1,CMAX)

 ... W !,?(INDENT+1),$E(PCLASS,CMAX+1,LEN)

 .. E  W !,?INDENT,PCLASS

 . S HEAD=0

 Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PXRRFDP   8741     printed  Sep 02, 2024@19:15:59                                                                                                                                                                                                     Page 2

PXRRFDP   ;ISL/PKR - Final sort and print of frequency of diagnosis report. ;05/17/2018

 +1       ;;1.0;PCE PATIENT CARE ENCOUNTER;**3,10,12,18,31,121,199,211**;Aug 12, 1996;Build 454

 +2       ;

PRINT     ;

 +1        NEW ANS,BD,BMARG,C1E,C1S,C2E,C2S,C3E,C3S,C1HS,C2HS,C3HS,CMAX,INDENT,MID

 +2        NEW DCSTR,HEAD,LEN,NUM,PAGE

 +3        NEW BYLOC,BYPC,BYPRV,DCIEN,DOCOUNT,DONE,DTOT,ED,ETOT,FOUND,HLOC,IC,ICD9IEN

 +4        NEW FACILITY,FACPNAME,IC,ICDDATA,ICDDATE,IMPDATE,INFOTYPE,LOCPNAM,NEWPAGE,PCLASS,PRV

 +5        NEW RATIO,STOIND,TEMP,TOTAL,TOTSTR,VACODE,ICDSTR

 +6       ;

 +7       ;Allow the task to be cleaned up upon successful completion.

 +8        SET ZTREQ="@"

 +9       ;

 +10       USE IO

 +11      ;ICR #5679

 +12       SET IMPDATE=$$IMPDATE^LEXU("10D")

 +13      ; When no Diagnoses found for Criteria for either ICD-9 or ICD-10, rpt Criteria

 +14      ; and End the run.

 +15       IF (DIAGTOT=0)&(DGTOT10=0)

               SET DOCOUNT=1

               DO PROCSS2

               GOTO END

 +16       FOR DOCOUNT=1:1:2

               DO PROCESS

 +17       GOTO END

 +18      ;

PROCESS   ;

 +1        IF DOCOUNT=1

               IF DIAGTOT=0

                   QUIT 

 +2        IF DOCOUNT=2

               IF DGTOT10=0

                   QUIT 

PROCSS2    SET ICDDATE=$SELECT(DOCOUNT=2:IMPDATE,1:$$FMADD^XLFDT(IMPDATE,-1))

 +1        SET BMARG=2

 +2        SET INDENT=3

           SET PAGE=1

           SET C1S=INDENT+29

 +3       ;

 +4        SET DONE=0

 +5        DO HDR^PXRRGPRT(PAGE)

 +6        WRITE !!,"Criteria for Frequency of Diagnoses Report"

 +7        WRITE !,?INDENT,"Encounter diagnoses:",?C1S,$PIECE(PXRRFDDC,U,2)

 +8        SET BD=$$FMTE^XLFDT(PXRRBDT)

 +9        SET ED=$$FMTE^XLFDT(PXRREDT)

 +10       WRITE !,?INDENT,"Encounter date range:",?C1S,BD," through ",ED

 +11       IF PXRRECAT=""

               Begin DoDot:1

 +12               WRITE !,?INDENT,"Selected encounters:",?C1S,"ALL"

               End DoDot:1

               GOTO MAXP

 +13      ;

 +14       IF $DATA(PXRRPRSC)

               WRITE !,?INDENT,"Selected Providers:",?C1S,$PIECE(PXRRPRSC,U,2)

 +15       IF $DATA(PXRRCS)

               SET ANS="YES"

 +16      IF '$TEST

               SET ANS="ALL"

 +17       IF $DATA(PXRRLCSC)

               WRITE !,?INDENT,$PIECE(PXRRLCSC,U,2)

 +18       IF $DATA(PXRRETYP)

               WRITE !,?INDENT,"Encounter type:",?C1S,PXRRETYP

 +19      ;

 +20       IF $DATA(PXRRDOB)

               Begin DoDot:1

 +21               IF (PXRRDOBE'=DT)&(PXRRDOBS'=0)

                       Begin DoDot:2

 +22                       WRITE !,?INDENT,"Patient age range:",?C1S,PXRRMINA," to ",PXRRMAXA

 +23                       SET BD=$$FMTE^XLFDT(PXRRDOBS)

                           SET ED=$$FMTE^XLFDT(PXRRDOBE)

 +24                       WRITE !,?INDENT,"Patient date of birth:",?C1S,BD," through ",ED

                       End DoDot:2

 +25               IF (PXRRDOBS=0)

                       Begin DoDot:2

 +26                       WRITE !,?INDENT,"Patient age range:",?C1S,PXRRMINA," or more"

 +27                       SET ED=$$FMTE^XLFDT(PXRRDOBE)

 +28                       WRITE !,?INDENT,"Patient date of birth:",?C1S,ED," or before"

                       End DoDot:2

 +29               IF (PXRRDOBE=DT)

                       Begin DoDot:2

 +30                       WRITE !,?INDENT,"Patient age range:",?C1S,"Up to ",PXRRMAXA

 +31                       SET BD=$$FMTE^XLFDT(PXRRDOBS)

                           SET ED=$$FMTE^XLFDT(DT)

 +32                       WRITE !,?INDENT,"Patient date of birth:",?C1S,BD," through ",ED

                       End DoDot:2

               End DoDot:1

 +33      IF '$TEST

               WRITE !,?INDENT,"Patient age range:",?C1S,"ALL"

 +34      ;

 +35       IF $DATA(PXRRRACE)

               Begin DoDot:1

 +36               NEW RACE

 +37               SET RACE="race"

 +38               IF NRACE>1

                       SET RACE="races"

 +39               WRITE !?INDENT,"Patient ",RACE,":",?C1S,$PIECE(PXRRRACE(1),U,2)

 +40               FOR IC=2:1:NRACE

                       WRITE !,?C1S,$PIECE(PXRRRACE(IC),U,2)

               End DoDot:1

 +41      IF '$TEST

               WRITE !?INDENT,"Patient race(s):",?C1S,"ALL"

 +42      ;

 +43       IF $DATA(PXRRSEX)

               WRITE !?INDENT,"Patient sex:",?C1S,$PIECE(PXRRSEX,U,2)

 +44      IF '$TEST

               WRITE !?INDENT,"Patient sex:",?C1S,"BOTH"

 +45      ;

 +46       IF $DATA(PXRRSCAT)

               DO OSCAT^PXRRGPRT(PXRRSCAT,INDENT)

 +47      ;

 +48       IF $PIECE($GET(PXRRPRSC),U,1)="C"

               DO PECLASS^PXRRGPRT(INDENT)

 +49      ;

MAXP       WRITE !!,?INDENT,"Maximum number of diagnoses to be displayed: ",PXRRDMAX

 +1       ;

 +2        SET CMAX=70

 +3       ;

 +4        IF $DATA(PXRRLCSC)

               Begin DoDot:1

 +5                IF PXRRLCSC["C"

                       SET PLOCNAM="Clinic Stop: "

 +6                IF PXRRLCSC["H"

                       SET PLOCNAM="Hospital Location: "

               End DoDot:1

 +7       ;

 +8        SET FACILITY=""

NFAC       SET INFOTYPE="FACILITY"

 +1        SET FACILITY=$ORDER(^XTMP(PXRRXTMP,"INFO",INFOTYPE,FACILITY))

 +2        IF +FACILITY=0

               QUIT 

 +3       ;Mark the facility as being found.

 +4        FOR IC=1:1:NFAC

               IF $PIECE(PXRRFAC(IC),U,1)=FACILITY

                   Begin DoDot:1

 +5                    SET $PIECE(PXRRFAC(IC),U,4)="M"

                   End DoDot:1

                   QUIT 

 +6        SET FACPNAME=$PIECE(PXRRFACN(FACILITY),U,1)_"  "_$PIECE(PXRRFACN(FACILITY),U,2)

 +7       ;

 +8       ;Check for a user request to stop the task.

 +9        IF $$S^%ZTLOAD

               SET ZTSTOP=1

               DO EXIT^PXRRFDD

 +10      ;

NINFO      SET INFOTYPE=$ORDER(^XTMP(PXRRXTMP,"INFO",INFOTYPE))

 +1        IF INFOTYPE=""

               GOTO NFAC

 +2       ;

 +3        IF INFOTYPE["LOC"

               SET BYLOC=1

 +4       IF '$TEST

               SET BYLOC=0

 +5        IF INFOTYPE["PC"

               SET BYPC=1

 +6       IF '$TEST

               SET BYPC=0

 +7        IF INFOTYPE["PRV"

               SET BYPRV=1

 +8       IF '$TEST

               SET BYPRV=0

 +9       ;

 +10       SET PRV=""

NPRV      ;

 +1        SET PRV=$ORDER(^XTMP(PXRRXTMP,"INFO",INFOTYPE,FACILITY,PRV))

 +2        IF PRV=""

               GOTO NINFO

 +3       ;

 +4        SET VACODE=""

NVACODE   ;

 +1        SET VACODE=$ORDER(^XTMP(PXRRXTMP,"INFO",INFOTYPE,FACILITY,PRV,VACODE))

 +2        IF VACODE=""

               GOTO NPRV

 +3       ;

 +4        SET HLOC=""

NLOC       SET HLOC=$ORDER(^XTMP(PXRRXTMP,"INFO",INFOTYPE,FACILITY,PRV,VACODE,HLOC))

 +1        IF HLOC=""

               GOTO NVACODE

 +2       ;

 +3        SET STOIND=^XTMP(PXRRXTMP,"INFO",INFOTYPE,FACILITY,PRV,VACODE,HLOC)

 +4       ;

 +5       ;If the report is by provider get a person class for the provider.

 +6        IF BYPRV

               Begin DoDot:1

 +7                SET TEMP=$PIECE(PRV,U,4)

 +8                IF $LENGTH(TEMP)>0

                       SET PCLASS=$$ABBRV^PXRRPECU(TEMP)

 +9               IF '$TEST

                       SET PCLASS="Unknown"

               End DoDot:1

 +10      ;

 +11      ;If the report is by person class get the person class.

 +12       IF BYPC

               Begin DoDot:1

 +13               SET PCLASS=$$ABBRV^PXRRPECU(VACODE)

               End DoDot:1

 +14      ;

 +15       SET HEAD=1

 +16       DO HEAD(0)

 +17       IF DONE

               GOTO EXIT

 +18       SET C1S=INDENT+60

 +19       IF $Y>(IOSL-BMARG-4)

               DO HEAD(1)

 +20       IF DONE

               GOTO EXIT

 +21       IF $PIECE(PXRRFDDC,U,1)="P"

               SET TEMP="Total number of Primary Diagnoses for these Encounters:"

 +22      IF '$TEST

               SET TEMP="Total number of Diagnoses for these Encounters:"

 +23       IF $DATA(^XTMP(PXRRXTMP,"TOTALS","ENCTOT",STOIND))

               SET ETOT=^XTMP(PXRRXTMP,"TOTALS","ENCTOT",STOIND)

 +24      IF '$TEST

               SET ETOT=0

 +25       SET TOTSTR=$SELECT(DOCOUNT=1:"DIAGTOT",1:"DGTOT10")

 +26       IF $DATA(^XTMP(PXRRXTMP,"TOTALS",TOTSTR,STOIND))

               SET DTOT=^XTMP(PXRRXTMP,"TOTALS",TOTSTR,STOIND)

 +27      IF '$TEST

               SET DTOT=0

 +28       SET LEN=$$MAX^XLFMTH($LENGTH(DTOT),$LENGTH(ETOT))

 +29       WRITE !!,?INDENT,"Total number of Encounters meeting the selection criteria:",?C1S,$JUSTIFY(ETOT,LEN)

 +30       WRITE !,?INDENT,TEMP,?C1S,$JUSTIFY(DTOT,LEN)

 +31       SET RATIO=$SELECT(ETOT>0:(DTOT/ETOT),1:0)

 +32       WRITE !,?INDENT,"Diagnoses/Encounter ratio:",?C1S,$JUSTIFY(RATIO,LEN,2)

 +33      ;

 +34       SET C1S=INDENT+8

           SET C2E=INDENT+59

 +35       SET C1HS=INDENT+9

           SET C2HS=INDENT+33

 +36       SET TOTAL=""

 +37       SET NUM=0

           SET ICDSTR=$SELECT(DOCOUNT=1:"ICD9",1:"ICD10")

NTOTICD    SET TOTAL=$ORDER(^XTMP(PXRRXTMP,"PRINT",STOIND,ICDSTR,TOTAL),-1)

 +1        IF TOTAL=""

               GOTO DIAGCAT

 +2        SET TEMP=TOTAL

 +3        SET ICD9IEN=""

NICD9      SET ICD9IEN=$ORDER(^XTMP(PXRRXTMP,"PRINT",STOIND,ICDSTR,TOTAL,ICD9IEN),-1)

 +1        IF ICD9IEN=""

               GOTO NTOTICD

 +2        SET NUM=NUM+1

 +3        IF NUM=1

               SET HEAD=1

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

               SET NEWPAGE=1

 +5       IF '$TEST

               SET NEWPAGE=0

 +6        DO DHEAD(NEWPAGE)

 +7        IF DONE

               GOTO EXIT

 +8        SET C3S=C3E-$LENGTH(TEMP)

 +9        SET ICDDATA=$$ICDDATA^ICDXCODE("DIAG",ICD9IEN,ICDDATE,"I")

 +10       WRITE !," ",$PIECE(ICDDATA,U,2),?11,$EXTRACT($PIECE(ICDDATA,U,4),1,60),?72,$JUSTIFY($FNUMBER(TEMP,",",0),7)

 +11       IF NUM<PXRRDMAX

               GOTO NICD9

DIAGCAT   ;

 +1        SET C1S=INDENT+8

           SET C1E=INDENT+38

 +2        SET C1HS=14

 +3        SET TOTAL=""

 +4        SET NUM=0

 +5        SET DCSTR=$SELECT(DOCOUNT=1:"DC",1:"DC10")

NTOTDC     SET TOTAL=$ORDER(^XTMP(PXRRXTMP,"PRINT",STOIND,DCSTR,TOTAL),-1)

 +1        IF TOTAL=""

               GOTO NLOC

 +2        SET TEMP=TOTAL

 +3        SET DCIEN=""

NDC        SET DCIEN=$ORDER(^XTMP(PXRRXTMP,"PRINT",STOIND,DCSTR,TOTAL,DCIEN),-1)

 +1        IF DCIEN=""

               GOTO NTOTDC

 +2        SET NUM=NUM+1

 +3        IF NUM=1

               SET HEAD=1

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

               SET NEWPAGE=1

 +5       IF '$TEST

               SET NEWPAGE=0

 +6        DO DCHEAD(NEWPAGE)

 +7        IF DONE

               GOTO EXIT

 +8        SET C2S=C2E-$LENGTH(TEMP)

 +9       ;We will need a DBIA to read ICM.  Some sites have had a corrupted ICM

 +10      ;file.  Check for this problem, if found print an error message and

 +11      ;quit.

 +12       IF (DCIEN>0)&('$DATA(^ICM(DCIEN,0)))

               Begin DoDot:1

 +13               WRITE !!,"CANNOT CONTINUE, File 80.3 Major Diagnostic Category is corrupted!"

 +14               WRITE !,"^ICM(",DCIEN,",0) is missing."

 +15               WRITE !,"Please contact customer service for help."

               End DoDot:1

               GOTO EXIT

 +16       IF DCIEN>0

               WRITE !,?INDENT,$JUSTIFY(NUM,5),".",?C1S,$PIECE(^ICM(DCIEN,0),U,1),?C2S,TEMP

 +17      IF '$TEST

               WRITE !,?INDENT,$JUSTIFY(NUM,5),".",?C1S,"Unknown",?C2S,TEMP

 +18       IF NUM<PXRRDMAX

               GOTO NDC

 +19      ;

 +20      ;Get the next location.

 +21       GOTO NLOC

END       ;

 +1       ;Check for facilities that were listed but had no encounters.

 +2        DO FACNE^PXRRGPRT(INDENT)

EXIT      ;

 +1        DO EXIT^PXRRGUT

 +2        DO EOR^PXRRGUT

 +3        QUIT 

 +4       ;

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

DHEAD(NEWPAGE) ;

 +1        NEW DASH60

           SET $PIECE(DASH60,"-",61)=""

 +2        IF NEWPAGE

               DO PAGE^PXRRGPRT

 +3       IF '$TEST

               IF $Y>(IOSL-BMARG)

                   DO PAGE^PXRRGPRT

 +4        IF DONE

               QUIT 

 +5        IF (HEAD)&(RATIO>0)

               Begin DoDot:1

 +6                SET LEN=$$MAX^XLFMTH(9,$LENGTH(TEMP))

 +7                SET MID=C2E+3+(LEN/2)

 +8                SET C3HS=MID-5

 +9                SET C3E=MID+($LENGTH(TEMP)/2)

 +10               WRITE !!,?INDENT,PXRRDMAX," Most Frequent ICD-",$SELECT(DOCOUNT=1:"9",1:"10")," Diagnoses:"

 +11               WRITE !," Code",?11,"Description",?72,"Freq."

 +12               WRITE !," --------",?11,DASH60,?72,"-------"

 +13               SET HEAD=0

               End DoDot:1

 +14       QUIT 

 +15      ;

 +16      ;=======================================================================

DCHEAD(NEWPAGE) ;

 +1        IF NEWPAGE

               DO PAGE^PXRRGPRT

 +2       IF '$TEST

               IF $Y>(IOSL-BMARG)

                   DO PAGE^PXRRGPRT

 +3        IF DONE

               QUIT 

 +4        IF (HEAD)&(RATIO>0)

               Begin DoDot:1

 +5                SET LEN=$$MAX^XLFMTH(9,$LENGTH(TEMP))

 +6                SET MID=C1E+3+(LEN/2)

 +7                SET C2HS=MID-5

 +8                SET C2E=MID+($LENGTH(TEMP)/2)

 +9                WRITE !!,?INDENT,PXRRDMAX," Most Frequent ICD-",$SELECT(DOCOUNT=1:"9",1:"10")," Diagnostic Categories:"

 +10               WRITE !,?C1HS,"Diagnostic Category",?C2HS,"Frequency"

 +11               WRITE !,?C1S,"------------------------------",?C2HS,"---------"

 +12               SET HEAD=0

               End DoDot:1

 +13       QUIT 

 +14      ;

 +15      ;=======================================================================

HEAD(NEWPAGE) ;

 +1        NEW LEN,TEMP

 +2        IF NEWPAGE

               DO PAGE^PXRRGPRT

 +3       IF '$TEST

               IF $Y>(IOSL-BMARG-8)

                   DO PAGE^PXRRGPRT

 +4        IF DONE

               QUIT 

 +5        IF HEAD

               Begin DoDot:1

 +6                WRITE !!,"___________________________________________________________________"

 +7                WRITE !,"Facility: ",FACPNAME

 +8                IF BYLOC

                       WRITE !,PLOCNAM,$PIECE(HLOC,U,1)_" (",$PIECE(HLOC,U,3)_")"

 +9                IF BYPRV

                       Begin DoDot:2

 +10                       SET TEMP="Provider: "_$PIECE(PRV,U,1)_" ("_PCLASS_")"

 +11                       SET LEN=$LENGTH(TEMP)

 +12                       IF LEN>CMAX

                               Begin DoDot:3

 +13                               WRITE !,$EXTRACT(TEMP,1,CMAX)

 +14                               WRITE !," ",$EXTRACT(TEMP,CMAX+1,LEN)

                               End DoDot:3

 +15                      IF '$TEST

                               WRITE !,TEMP

                       End DoDot:2

 +16               IF BYPC

                       Begin DoDot:2

 +17                       WRITE !,"Person Class (Occupation+Specialty+Subspecialty): "

 +18                       SET LEN=INDENT+$LENGTH(PCLASS)

 +19                       IF LEN>CMAX

                               Begin DoDot:3

 +20                               WRITE !,?INDENT,$EXTRACT(PCLASS,1,CMAX)

 +21                               WRITE !,?(INDENT+1),$EXTRACT(PCLASS,CMAX+1,LEN)

                               End DoDot:3

 +22                      IF '$TEST

                               WRITE !,?INDENT,PCLASS

                       End DoDot:2

 +23               SET HEAD=0

               End DoDot:1

 +24       QUIT 

 +25      ;