APCLOSP6.m

APCLOSP6 ; IHS/CMI/LAB - INHOSP PRINT ;

 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58

 ;

POV ;

 I $Y>(IOSL-15) D HEAD^APCLOSP Q:$D(APCLQUIT)

 S APCL1="INHOSPPOV",APCL2="INHOSPPOVC",APCLMAX=10,APCLGLOB="^ICD9(",APCLPIEC=3

 W !!,"The ten leading purposes of In-Hospital visits by individual ICD Code ",!,"are listed below.  Both primary and secondary diagnoses are included in the counts.",!

 W !?11,"By ICD Diagnosis"

 D PROC

APC ;

 Q  ;no more 1/6/2002

 I $Y>(IOSL-12) D HEAD^APCLOSP Q:$D(APCLQUIT)

 S APCL1="INHOSPAPC",APCL2="INHOSPAPCC",APCLMAX=10,APCLGLOB="^AUTTRCD(",APCLPIEC=3

 W !!?11,"By APC Code"

 D PROC

 Q

PROC S (APCLC,APCLN)=0 F  S APCLN=$O(^XTMP("APCLOS",APCLJOB,APCLBTH,APCL2,APCLN)) Q:APCLN=""!(APCLC=APCLMAX)  D PROC1

 Q

PROC1 ;

 S APCLD=0 F  S APCLD=$O(^XTMP("APCLOS",APCLJOB,APCLBTH,APCL2,APCLN,APCLD)) Q:APCLD=""!(APCLC=APCLMAX)  D PROC2

 Q

PROC2 ;

 S APCLC=APCLC+1

 S X=^XTMP("APCLOS",APCLJOB,APCLBTH,APCL2,APCLN,APCLD)

 S APCLPD=0 F  S APCLPD=$O(^XTMP("APCLOSP",APCLJOB,APCLBTH,APCL1,APCLPD)) Q:APCLD=APCLPD!(APCLPD="")

 S Y=$S(APCLPD]"":^XTMP("APCLOSP",APCLJOB,APCLBTH,APCL1,APCLPD),1:0) D CALC^APCLOSUT

 S G=APCLGLOB_APCLD_")"

 W !?5,APCLC,").  ",?10,$E($P($$ICDDX^ICDEX(APCLD),U,4),1,40),?45,$J(X,7),?56,"(",Z,")"

 Q

APCLOSP6  ; IHS/CMI/LAB - INHOSP PRINT ;

 +1       ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58

 +2       ;

POV       ;

 +1        IF $Y>(IOSL-15)

               DO HEAD^APCLOSP

               IF $DATA(APCLQUIT)

                   QUIT 

 +2        SET APCL1="INHOSPPOV"

           SET APCL2="INHOSPPOVC"

           SET APCLMAX=10

           SET APCLGLOB="^ICD9("

           SET APCLPIEC=3

 +3        WRITE !!,"The ten leading purposes of In-Hospital visits by individual ICD Code ",!,"are listed below.  Both primary and secondary diagnoses are included in the counts.",!

 +4        WRITE !?11,"By ICD Diagnosis"

 +5        DO PROC

APC       ;

 +1       ;no more 1/6/2002

           QUIT 

 +2        IF $Y>(IOSL-12)

               DO HEAD^APCLOSP

               IF $DATA(APCLQUIT)

                   QUIT 

 +3        SET APCL1="INHOSPAPC"

           SET APCL2="INHOSPAPCC"

           SET APCLMAX=10

           SET APCLGLOB="^AUTTRCD("

           SET APCLPIEC=3

 +4        WRITE !!?11,"By APC Code"

 +5        DO PROC

 +6        QUIT 

PROC       SET (APCLC,APCLN)=0

           FOR 

               SET APCLN=$ORDER(^XTMP("APCLOS",APCLJOB,APCLBTH,APCL2,APCLN))

               IF APCLN=""!(APCLC=APCLMAX)

                   QUIT 

               DO PROC1

 +1        QUIT 

PROC1     ;

 +1        SET APCLD=0

           FOR 

               SET APCLD=$ORDER(^XTMP("APCLOS",APCLJOB,APCLBTH,APCL2,APCLN,APCLD))

               IF APCLD=""!(APCLC=APCLMAX)

                   QUIT 

               DO PROC2

 +2        QUIT 

PROC2     ;

 +1        SET APCLC=APCLC+1

 +2        SET X=^XTMP("APCLOS",APCLJOB,APCLBTH,APCL2,APCLN,APCLD)

 +3        SET APCLPD=0

           FOR 

               SET APCLPD=$ORDER(^XTMP("APCLOSP",APCLJOB,APCLBTH,APCL1,APCLPD))

               IF APCLD=APCLPD!(APCLPD="")

                   QUIT 

 +4        SET Y=$SELECT(APCLPD]"":^XTMP("APCLOSP",APCLJOB,APCLBTH,APCL1,APCLPD),1:0)

           DO CALC^APCLOSUT

 +5        SET G=APCLGLOB_APCLD_")"

 +6        WRITE !?5,APCLC,").  ",?10,$EXTRACT($PIECE($$ICDDX^ICDEX(APCLD),U,4),1,40),?45,$JUSTIFY(X,7),?56,"(",Z,")"

 +7        QUIT