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
Q
CNT1 S APCLCNT=^XTMP("APCLPVC",APCLJOB,APCLBT,APCLAPC,APCLINO)
S ^XTMP("APCLPVC",APCLJOB,APCLBT,"APCLCNT","APCLINO",APCLAPC,-APCLCNT,APCLINO)=APCLCNT
Q
PRNT1 S APCLCNTR=""
F S APCLCNTR=$O(^XTMP("APCLPVC",APCLJOB,APCLBT,"APCLCNT",APCLCNTR)) Q:APCLCNTR'=+APCLCNTR!($D(APCLQUIT)) D PRNT2
Q
PRNT2 S APCLAPC=""
F S APCLAPC=$O(^XTMP("APCLPVC",APCLJOB,APCLBT,"APCLCNT",APCLCNTR,APCLAPC)) Q:APCLAPC'=+APCLAPC!($D(APCLQUIT)) D PRNT3
Q
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)
Q
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
Q
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
Q
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
Q
DONE ;
D DONE^APCLOSUT
K ^XTMP("APCLPVC",APCLJOB,APCLBT)
Q
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
