APCLAUD2 ; IHS/CMI/LAB - more audit report ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;IHS/CMI/LAB patch 4 Y2K
;
;cmi/anch/maw 9/7/2007 code set versioning in PR11
;
START ;
D TOPHD^APCLAUD4,TOP^APCLAUD4 Q:$D(APCLQ) S APCLPG=0 D HEAD Q:$D(APCLQ) D PR Q
PR I $Y>(IOSL-5) D HEAD Q:$D(APCLQ)
Q:$D(APCLQ)
PR01 S APCLPNO=""
F S APCLPNO=$O(^XTMP("APCLAUD2",APCLJOB,APCLBT,APCLPNO)) Q:APCLPNO=""!($D(APCLQ)) D PR1
D DONE^APCLOSUT
K ^XTMP("APCLAUD",APCLJOB,APCLBT),^XTMP("APCLAUD2",APCLJOB,APCLBT)
Q
PR1 S APCLIRNG="" F S APCLIRNG=$O(^XTMP("APCLAUD2",APCLJOB,APCLBT,APCLPNO,APCLIRNG)) Q:APCLIRNG=""!($D(APCLQ)) D PR10
Q
PR10 I $D(^XTMP("APCLAUD2",APCLJOB,APCLBT,APCLPNO,APCLIRNG,0)) S APCLCNT=^(0) D SETCAR S APCLCNTR=0 D ICDLN^APCLAUD4 Q:$D(APCLQ)
S APCLINO=0
F S APCLINO=$O(^XTMP("APCLAUD2",APCLJOB,APCLBT,APCLPNO,APCLIRNG,APCLINO)) Q:APCLINO=""!($D(APCLQ)) D PR11
Q
PR11 ;
;S APCLICNO=$P(^ICD9(APCLINO,0),"^"),APCLVNO=0
S APCLICNO=$P($$ICDDX^ICDEX(APCLINO),"^",2),APCLVNO=0
F S APCLVNO=$O(^XTMP("APCLAUD2",APCLJOB,APCLBT,APCLPNO,APCLIRNG,APCLINO,APCLVNO)) Q:APCLVNO=""!($D(APCLQ)) D PR12
Q
PR12 G:$D(APCLALLR) PR120
S APCLCNTR=APCLCNTR+1
Q:'$D(APCLCAR(APCLCNTR))
PR120 S APCLVDT=$P($P(^AUPNVSIT(APCLVNO,0),"^"),"."),Y=APCLVDT X ^DD("DD") S APCLVDT=Y,APCLPTNM=$P(^AUPNVSIT(APCLVNO,0),"^",5),APCLHRN=$S($D(^AUPNPAT(APCLPTNM,41,APCLSITE,0)):$P(^(0),"^",2),1:"")
S APCLPAT=$S($D(^DPT(APCLPTNM,0)):$P(^DPT(APCLPTNM,0),U),1:""),DOB=$S($D(^DPT(APCLPTNM,0)):$P(^DPT(APCLPTNM,0),U,3),1:"")
S APCLPNO1=$P(^XTMP("APCLAUD2",APCLJOB,APCLBT,APCLPNO,APCLIRNG,APCLINO,APCLVNO),U),APCLPOVD=$P(^(APCLVNO),U,2)
S APCLINM=$$VAL^XBDIQ1(9000010.07,APCLPOVD,.04)
S APCLPNM=$S($P(^DD(9000010.06,.01,0),U,2)[200:$P(^VA(200,APCLPNO1,0),U),1:$P(^DIC(16,$P(^DIC(6,APCLPNO1,0),"^"),0),"^"))
I $Y>(IOSL-5) D HEAD Q:$D(APCLQ)
;begin Y2K
;W !!,$J(APCLHRN,7),?10,APCLVDT,?24,$E(APCLPNM,1,20),?45,$E(APCLPAT,1,24),?70,$E(DOB,4,5),"/",$E(DOB,6,7),"/",$E(DOB,2,3),!?10,APCLICNO,?24,$E(APCLINM,1,59) ;Y2000
W !!,$J(APCLHRN,7),?10,APCLVDT,?24,$E(APCLPNM,1,20),?45,$E(APCLPAT,1,24),?70,$E(DOB,4,5),"/",$E(DOB,6,7),"/",(1700+($E(DOB,1,3))),!?10,APCLICNO,?24,$E(APCLINM,1,55) ;Y2000
;end Y2K
Q
HEAD ;EP
;I $D(APCLQ) Q
S APCLPG=APCLPG+1 G:APCLPG=1 HEAD1
I $E(IOST)="C" S DIR(0)="EO" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) S APCLQ=1
HEAD1 W:$D(IOF) @IOF
W $P(^DIC(4,APCLSITE,0),"^"),?58,APCLDTP,?72,"Page ",APCLPG,!
W !,"Audit Search for Ambulatory Visits from ",APCLBDY," through ",APCLEDY,"."
W !!,"HRCN",?10,"Visit Date",?24,"Primary Provider",?45,"Patient Name",?70,"DOB",!?10,"ICD9",?24,"DIAGNOSIS"
W !,APCL80D
Q
SETCAR K APCLCAR
G:APCLLIM<APCLCNT SCR0 F APCLIJ=1:1:APCLCNT S APCLCAR(APCLIJ)=""
S APCLGOT=APCLCNT
Q
SCR0 S (APCLGOT,APCLSKP)=0
SCR1 Q:APCLSKP>100
Q:APCLGOT=APCLLIM
S X=$R(APCLCNT) G:X=0 SCR1
I $D(APCLCAR(X)) S APCLSKP=APCLSKP+1 G SCR1
S APCLCAR(X)="",APCLGOT=APCLGOT+1 G SCR1
Q
APCLAUD2 ; IHS/CMI/LAB - more audit report ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;IHS/CMI/LAB patch 4 Y2K
+3 ;
+4 ;cmi/anch/maw 9/7/2007 code set versioning in PR11
+5 ;
START ;
+1 DO TOPHD^APCLAUD4
DO TOP^APCLAUD4
IF $DATA(APCLQ)
QUIT
SET APCLPG=0
DO HEAD
IF $DATA(APCLQ)
QUIT
DO PR
QUIT
PR IF $Y>(IOSL-5)
DO HEAD
IF $DATA(APCLQ)
QUIT
+1 IF $DATA(APCLQ)
QUIT
PR01 SET APCLPNO=""
+1 FOR
SET APCLPNO=$ORDER(^XTMP("APCLAUD2",APCLJOB,APCLBT,APCLPNO))
IF APCLPNO=""!($DATA(APCLQ))
QUIT
DO PR1
+2 DO DONE^APCLOSUT
+3 KILL ^XTMP("APCLAUD",APCLJOB,APCLBT),^XTMP("APCLAUD2",APCLJOB,APCLBT)
+4 QUIT
PR1 SET APCLIRNG=""
FOR
SET APCLIRNG=$ORDER(^XTMP("APCLAUD2",APCLJOB,APCLBT,APCLPNO,APCLIRNG))
IF APCLIRNG=""!($DATA(APCLQ))
QUIT
DO PR10
+1 QUIT
PR10 IF $DATA(^XTMP("APCLAUD2",APCLJOB,APCLBT,APCLPNO,APCLIRNG,0))
SET APCLCNT=^(0)
DO SETCAR
SET APCLCNTR=0
DO ICDLN^APCLAUD4
IF $DATA(APCLQ)
QUIT
+1 SET APCLINO=0
+2 FOR
SET APCLINO=$ORDER(^XTMP("APCLAUD2",APCLJOB,APCLBT,APCLPNO,APCLIRNG,APCLINO))
IF APCLINO=""!($DATA(APCLQ))
QUIT
DO PR11
+3 QUIT
PR11 ;
+1 ;S APCLICNO=$P(^ICD9(APCLINO,0),"^"),APCLVNO=0
+2 SET APCLICNO=$PIECE($$ICDDX^ICDEX(APCLINO),"^",2)
SET APCLVNO=0
+3 FOR
SET APCLVNO=$ORDER(^XTMP("APCLAUD2",APCLJOB,APCLBT,APCLPNO,APCLIRNG,APCLINO,APCLVNO))
IF APCLVNO=""!($DATA(APCLQ))
QUIT
DO PR12
+4 QUIT
PR12 IF $DATA(APCLALLR)
GOTO PR120
+1 SET APCLCNTR=APCLCNTR+1
+2 IF '$DATA(APCLCAR(APCLCNTR))
QUIT
PR120 SET APCLVDT=$PIECE($PIECE(^AUPNVSIT(APCLVNO,0),"^"),".")
SET Y=APCLVDT
XECUTE ^DD("DD")
SET APCLVDT=Y
SET APCLPTNM=$PIECE(^AUPNVSIT(APCLVNO,0),"^",5)
SET APCLHRN=$SELECT($DATA(^AUPNPAT(APCLPTNM,41,APCLSITE,0)):$PIECE(^(0),"^",2),1:"")
+1 SET APCLPAT=$SELECT($DATA(^DPT(APCLPTNM,0)):$PIECE(^DPT(APCLPTNM,0),U),1:"")
SET DOB=$SELECT($DATA(^DPT(APCLPTNM,0)):$PIECE(^DPT(APCLPTNM,0),U,3),1:"")
+2 SET APCLPNO1=$PIECE(^XTMP("APCLAUD2",APCLJOB,APCLBT,APCLPNO,APCLIRNG,APCLINO,APCLVNO),U)
SET APCLPOVD=$PIECE(^(APCLVNO),U,2)
+3 SET APCLINM=$$VAL^XBDIQ1(9000010.07,APCLPOVD,.04)
+4 SET APCLPNM=$SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:$PIECE(^VA(200,APCLPNO1,0),U),1:$PIECE(^DIC(16,$PIECE(^DIC(6,APCLPNO1,0),"^"),0),"^"))
+5 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(APCLQ)
QUIT
+6 ;begin Y2K
+7 ;W !!,$J(APCLHRN,7),?10,APCLVDT,?24,$E(APCLPNM,1,20),?45,$E(APCLPAT,1,24),?70,$E(DOB,4,5),"/",$E(DOB,6,7),"/",$E(DOB,2,3),!?10,APCLICNO,?24,$E(APCLINM,1,59) ;Y2000
+8 ;Y2000
WRITE !!,$JUSTIFY(APCLHRN,7),?10,APCLVDT,?24,$EXTRACT(APCLPNM,1,20),?45,$EXTRACT(APCLPAT,1,24),?70,$EXTRACT(DOB,4,5),"/",$EXTRACT(DOB,6,7),"/",(1700+($EXTRACT(DOB,1,3))),!?10,APCLICNO,?24,$EXTRACT(APCLINM,1,55)
+9 ;end Y2K
+10 QUIT
HEAD ;EP
+1 ;I $D(APCLQ) Q
+2 SET APCLPG=APCLPG+1
IF APCLPG=1
GOTO HEAD1
+3 IF $EXTRACT(IOST)="C"
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+4 IF $DATA(DIRUT)
SET APCLQ=1
HEAD1 IF $DATA(IOF)
WRITE @IOF
+1 WRITE $PIECE(^DIC(4,APCLSITE,0),"^"),?58,APCLDTP,?72,"Page ",APCLPG,!
+2 WRITE !,"Audit Search for Ambulatory Visits from ",APCLBDY," through ",APCLEDY,"."
+3 WRITE !!,"HRCN",?10,"Visit Date",?24,"Primary Provider",?45,"Patient Name",?70,"DOB",!?10,"ICD9",?24,"DIAGNOSIS"
+4 WRITE !,APCL80D
+5 QUIT
SETCAR KILL APCLCAR
+1 IF APCLLIM<APCLCNT
GOTO SCR0
FOR APCLIJ=1:1:APCLCNT
SET APCLCAR(APCLIJ)=""
+2 SET APCLGOT=APCLCNT
+3 QUIT
SCR0 SET (APCLGOT,APCLSKP)=0
SCR1 IF APCLSKP>100
QUIT
+1 IF APCLGOT=APCLLIM
QUIT
+2 SET X=$RANDOM(APCLCNT)
IF X=0
GOTO SCR1
+3 IF $DATA(APCLCAR(X))
SET APCLSKP=APCLSKP+1
GOTO SCR1
+4 SET APCLCAR(X)=""
SET APCLGOT=APCLGOT+1
GOTO SCR1
+5 QUIT
