Routine: APCLPVC2

APCLPVC2 ; IHS/CMI/LAB - POV GROUPED BY APC CODES - 6/21/89 10:58 AM ;

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

 ;SORT AND PRINT APC RECODED PCC AMBULATORY VISIT COUNTS

 ;cmi/anch/maw 9/10/2007 code set versioning in PRICD1

 S APCL80D="-------------------------------------------------------------------------------" ;80 DASHES

 S Y=APCLSD X ^DD("DD") S APCLSDY=Y S Y=APCLFD X ^DD("DD") S APCLFDY=Y S Y=DT X ^DD("DD") S APCLDTP=Y

 S APCLSITE=DUZ(2)

 S (APCLPG,APCLCNT)=0

 S APCLAPC=""

 F I=0:0 S APCLAPC=$O(^XTMP("APCLPVC",APCLJOB,APCLBT,APCLAPC)) Q:APCLAPC'=+APCLAPC  D CNT

 D PRNT1 G DONE

CNT S APCLCNT=^XTMP("APCLPVC",APCLJOB,APCLBT,APCLAPC,0)

 S ^XTMP("APCLPVC",APCLJOB,APCLBT,"APCLCNT",-APCLCNT,APCLAPC)=APCLCNT

 S APCLINO=0

 F  S APCLINO=$O(^XTMP("APCLPVC",APCLJOB,APCLBT,APCLAPC,APCLINO)) Q:APCLINO=""  D CNT1

CNT1 S APCLCNT=^XTMP("APCLPVC",APCLJOB,APCLBT,APCLAPC,APCLINO)

 S ^XTMP("APCLPVC",APCLJOB,APCLBT,"APCLCNT","APCLINO",APCLAPC,-APCLCNT,APCLINO)=APCLCNT

PRNT1 S APCLCNTR=""

 F  S APCLCNTR=$O(^XTMP("APCLPVC",APCLJOB,APCLBT,"APCLCNT",APCLCNTR)) Q:APCLCNTR'=+APCLCNTR!($D(APCLQUIT))  D PRNT2

PRNT2 S APCLAPC=""

 F  S APCLAPC=$O(^XTMP("APCLPVC",APCLJOB,APCLBT,"APCLCNT",APCLCNTR,APCLAPC)) Q:APCLAPC'=+APCLAPC!($D(APCLQUIT))  D PRNT3

PRNT3 S APCLCNT=^XTMP("APCLPVC",APCLJOB,APCLBT,"APCLCNT",APCLCNTR,APCLAPC)

 S APCLAPNM=$O(^AUTTRCD("B",APCLAPC,"")),APCLAPNM=$P(^AUTTRCD(APCLAPNM,0),"^",3)

 I APCLPG=0 D HEAD

 I $Y>(IOSL-8) D HEAD Q:$D(APCLQUIT)

 W !!!,APCLAPC,?7,APCLAPNM,?54,$J(APCLCNT,6),!

 Q:APCLLIM=0

 W !?7,"ICD9",?14,"ICD9 Description",!?7,"------",?14,"------------------------"

 S APCLCNTL=0,APCLCNTI="",APCLLIMC=0 F  S APCLCNTI=$O(^XTMP("APCLPVC",APCLJOB,APCLBT,"APCLCNT","APCLINO",APCLAPC,APCLCNTI)) Q:APCLCNTI=""!(APCLLIMC'<APCLLIM)!($D(APCLQUIT))  D PRICD

 I APCLLIMC'<APCLLIM,APCLCNT>APCLCNTL W !?14,"Other ICD9 Codes",?54,$J(APCLCNT-APCLCNTL,6)

PRICD S APCLINO=0 F  S APCLINO=$O(^XTMP("APCLPVC",APCLJOB,APCLBT,"APCLCNT","APCLINO",APCLAPC,APCLCNTI,APCLINO)) Q:APCLINO=""!(APCLLIMC'<APCLLIM)!($D(APCLQUIT))  D PRICD1

PRICD1 S APCLLIMC=APCLLIMC+1

 ;S APCLINM=$P(^ICD9(APCLINO,0),"^",3),APCLICNO=$P(^(0),"^") S APCLICLN=$S($D(^(1)):$P(^(1),"^"),1:"")  ;cmi/anch/maw 9/10/2007 orig line

 S APCLINM=$P($$ICDDX^ICDEX(APCLINO),"^",4),APCLICNO=$P($$ICDDX^ICDEX(APCLINO),"^",2) S APCLICLN=$S($D(^ICD9(APCLINO,1)):$P(^ICD9(APCLINO,1),"^"),1:"")  ;cmi/anch/maw 9/10/2007 csv

 I $Y>(IOSL-3) D HEAD Q:$D(APCLQUIT)

 W !?7,APCLICNO,?14,APCLINM,?54,$J(-APCLCNTI,6)

 S APCLCNTL=APCLCNTL-APCLCNTI

HEAD S APCLPG=APCLPG+1 G:APCLPG=1 HEAD1

 I $E(IOST)="C",IO=IO(0) R X:DTIME I $E(X)="^"!('$T) S APCLQUIT="" Q

HEAD1 W:$D(IOF) @IOF

 W $P(^DIC(4,APCLSITE,0),"^"),?58,APCLDTP,?72,"Page ",APCLPG,!

 W !,"POV Counts for Ambulatory Visits from ",APCLSDY," through ",APCLFDY,"."

 I $D(APCLCOM) W !,"For Patients whose Community of Residence is ",APCLCOM,"."

 W !,"ICD9 Subcounts are restricted to the leading ",APCLLIM," Purposes of Visit.",!

 W !,"APC",?7,"APC Category",?55,"Count"

 W !,APCL80D

DONE ;

 D DONE^APCLOSUT

 K ^XTMP("APCLPVC",APCLJOB,APCLBT)

APCLPVC2  ; IHS/CMI/LAB - POV GROUPED BY APC CODES - 6/21/89 10:58 AM ;

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

 +2       ;SORT AND PRINT APC RECODED PCC AMBULATORY VISIT COUNTS

 +3       ;

 +4       ;cmi/anch/maw 9/10/2007 code set versioning in PRICD1

 +5       ;

 +6       ;80 DASHES

           SET APCL80D="-------------------------------------------------------------------------------"

 +7        SET Y=APCLSD

           XECUTE ^DD("DD")

           SET APCLSDY=Y

           SET Y=APCLFD

           XECUTE ^DD("DD")

           SET APCLFDY=Y

           SET Y=DT

           XECUTE ^DD("DD")

           SET APCLDTP=Y

 +8        SET APCLSITE=DUZ(2)

 +9        SET (APCLPG,APCLCNT)=0

 +10       SET APCLAPC=""

 +11       FOR I=0:0

               SET APCLAPC=$ORDER(^XTMP("APCLPVC",APCLJOB,APCLBT,APCLAPC))

               IF APCLAPC'=+APCLAPC

                   QUIT

               DO CNT

 +12       DO PRNT1

           GOTO DONE

CNT        SET APCLCNT=^XTMP("APCLPVC",APCLJOB,APCLBT,APCLAPC,0)

 +1        SET ^XTMP("APCLPVC",APCLJOB,APCLBT,"APCLCNT",-APCLCNT,APCLAPC)=APCLCNT

 +2        SET APCLINO=0

 +3        FOR

               SET APCLINO=$ORDER(^XTMP("APCLPVC",APCLJOB,APCLBT,APCLAPC,APCLINO))

               IF APCLINO=""

                   QUIT

               DO CNT1

 +4        QUIT

CNT1       SET APCLCNT=^XTMP("APCLPVC",APCLJOB,APCLBT,APCLAPC,APCLINO)

 +1        SET ^XTMP("APCLPVC",APCLJOB,APCLBT,"APCLCNT","APCLINO",APCLAPC,-APCLCNT,APCLINO)=APCLCNT

 +2        QUIT

PRNT1      SET APCLCNTR=""

 +1        FOR

               SET APCLCNTR=$ORDER(^XTMP("APCLPVC",APCLJOB,APCLBT,"APCLCNT",APCLCNTR))

               IF APCLCNTR'=+APCLCNTR!($DATA(APCLQUIT))

                   QUIT

               DO PRNT2

 +2        QUIT

PRNT2      SET APCLAPC=""

 +1        FOR

               SET APCLAPC=$ORDER(^XTMP("APCLPVC",APCLJOB,APCLBT,"APCLCNT",APCLCNTR,APCLAPC))

               IF APCLAPC'=+APCLAPC!($DATA(APCLQUIT))

                   QUIT

               DO PRNT3

 +2        QUIT

PRNT3      SET APCLCNT=^XTMP("APCLPVC",APCLJOB,APCLBT,"APCLCNT",APCLCNTR,APCLAPC)

 +1        SET APCLAPNM=$ORDER(^AUTTRCD("B",APCLAPC,""))

           SET APCLAPNM=$PIECE(^AUTTRCD(APCLAPNM,0),"^",3)

 +2        IF APCLPG=0

               DO HEAD

 +3        IF $Y>(IOSL-8)

               DO HEAD

               IF $DATA(APCLQUIT)

                   QUIT

 +4        WRITE !!!,APCLAPC,?7,APCLAPNM,?54,$JUSTIFY(APCLCNT,6),!

 +5        IF APCLLIM=0

               QUIT

 +6        WRITE !?7,"ICD9",?14,"ICD9 Description",!?7,"------",?14,"------------------------"

 +7        SET APCLCNTL=0

           SET APCLCNTI=""

           SET APCLLIMC=0

FOR

               SET APCLCNTI=$ORDER(^XTMP("APCLPVC",APCLJOB,APCLBT,"APCLCNT","APCLINO",APCLAPC,APCLCNTI))

               IF APCLCNTI=""!(APCLLIMC'<APCLLIM)!($DATA(APCLQUIT))

                   QUIT

               DO PRICD

 +8        IF APCLLIMC'<APCLLIM

               IF APCLCNT>APCLCNTL

                   WRITE !?14,"Other ICD9 Codes",?54,$JUSTIFY(APCLCNT-APCLCNTL,6)

 +9        QUIT

PRICD      SET APCLINO=0

FOR

               SET APCLINO=$ORDER(^XTMP("APCLPVC",APCLJOB,APCLBT,"APCLCNT","APCLINO",APCLAPC,APCLCNTI,APCLINO))

               IF APCLINO=""!(APCLLIMC'<APCLLIM)!($DATA(APCLQUIT))

                   QUIT

               DO PRICD1

 +1        QUIT

PRICD1     SET APCLLIMC=APCLLIMC+1

 +1       ;S APCLINM=$P(^ICD9(APCLINO,0),"^",3),APCLICNO=$P(^(0),"^") S APCLICLN=$S($D(^(1)):$P(^(1),"^"),1:"")  ;cmi/anch/maw 9/10/2007 orig line

 +2       ;cmi/anch/maw 9/10/2007 csv

           SET APCLINM=$PIECE($$ICDDX^ICDEX(APCLINO),"^",4)

           SET APCLICNO=$PIECE($$ICDDX^ICDEX(APCLINO),"^",2)

           SET APCLICLN=$SELECT($DATA(^ICD9(APCLINO,1)):$PIECE(^ICD9(APCLINO,1),"^"),1:"")

 +3        IF $Y>(IOSL-3)

               DO HEAD

               IF $DATA(APCLQUIT)

                   QUIT

 +4        WRITE !?7,APCLICNO,?14,APCLINM,?54,$JUSTIFY(-APCLCNTI,6)

 +5        SET APCLCNTL=APCLCNTL-APCLCNTI

 +6        QUIT

HEAD       SET APCLPG=APCLPG+1

           IF APCLPG=1

               GOTO HEAD1

 +1        IF $EXTRACT(IOST)="C"

               IF IO=IO(0)

                   READ X:DTIME

                   IF $EXTRACT(X)="^"!('$TEST)

                       SET APCLQUIT=""

                       QUIT

HEAD1      IF $DATA(IOF)

               WRITE @IOF

 +1        WRITE $PIECE(^DIC(4,APCLSITE,0),"^"),?58,APCLDTP,?72,"Page ",APCLPG,!

 +2        WRITE !,"POV Counts for Ambulatory Visits from ",APCLSDY," through ",APCLFDY,"."

 +3        IF $DATA(APCLCOM)

               WRITE !,"For Patients whose Community of Residence is ",APCLCOM,"."

 +4        WRITE !,"ICD9 Subcounts are restricted to the leading ",APCLLIM," Purposes of Visit.",!

 +5        WRITE !,"APC",?7,"APC Category",?55,"Count"

 +6        WRITE !,APCL80D

 +7        QUIT

DONE      ;

 +1        DO DONE^APCLOSUT

 +2        KILL ^XTMP("APCLPVC",APCLJOB,APCLBT)

 +3        QUIT

APCLPVC2.m