- 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
