APCDFPPV.m

APCDFPPV ; IHS/CMI/LAB - PRINT UNCODED DX ;

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

 ;

LOC ;

 K APCDLOCT S APCDLOCT=""

 S DIR(0)="S^A:ALL Locations/Facilities;S:One SERVICE UNIT'S Locations/Facilities;O:ONE Location/Facility",DIR("A")="Include Visits to Which Location/Facilities",DIR("B")="A"

 S DIR("A")="Enter a code indicating what LOCATIONS/FACILITIES are of interest",DIR("B")="O" K DA D ^DIR K DIR,DA

 G:$D(DIRUT) XIT

 S APCDLOCT=Y

 I APCDLOCT="A" G DATE

 D @APCDLOCT

 G:$D(APCDQUIT) LOC

DATE ;

 S APCDFILE=9000010.07

 W !!,"The search for Uncoded "_$P(^DIC(APCDFILE,0),U),"'s can begin at any date",!,"that you specify.  To get all of the uncoded entries enter a really early "

 W !,"date like 01/01/1930.  If you want to only review data for visits ",!,"in the past week, enter T-7.",!

 S APCDFUDT=""

 S DIR(0)="D^::EP",DIR("A")="Enter the Beginning Date to Search for Uncoded entries" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G LOC

 S APCDFUDT=Y

 S DIR(0)="D^::EP",DIR("A")="Enter the Ending Date to Search for Uncoded entries" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G LOC

 S APCDFUET=Y

 I APCDFUET<APCDFUDT W !,"Ending date cannot be before beginning date." G DATE

PROV ;

 K APCDPRVT S APCDPRVT=""

 S DIR(0)="S^A:ALL Providers (PRIMARY);O:ONE Provider (PRIMARY)",DIR("A")="Include Visits to Which Provider",DIR("B")="A"

 S DIR("A")="Enter a code indicating what LOCATIONS/FACILITIES are of interest",DIR("B")="O" K DA D ^DIR K DIR,DA

 G:$D(DIRUT) XIT

 S APCDPRVT=Y

 I APCDPRVT="A" G FILE

 K DIC S DIC("A")="Which Provider: ",DIC="^VA(200,",DIC(0)="AEMQ" D ^DIC K DIC,DA G:X="^" PROV K DIC,DA

 G:Y=-1 PROV

 S APCDPRVT("ONE")=+Y

FILE ;WHICH FILE?

 S APCDWFIL=""

 S DIR(0)="S^POV:V POV;PRB:PROBLEM LIST;PRC:V PROCEDURE;FH:FAMILY HISTORY;PHX:PERSONAL HISTORY;A:ALL OF THE ABOVE"

 S DIR("A")="Which File would like to print from",DIR("B")="A" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G PROV

 S APCDWFIL=Y

ZIS ;

 S APCDCODE=$P($$ICDDX^ICDEX(".9999"),U,1)

 I APCDCODE="" W !!,"ERROR -- .9999 NOT IN ICD DIAGNOSIS FILE, NOTIFY YOUR SUPERVISOR" H 3 G XIT

 S APCDCODO=$P($$ICDDX^ICDEX("ZZZ.999"),U,1)

 I APCDCODO="" W !!,"ERROR -- ZZZ.999 NOT IN ICD DIAGNOSIS FILE, NOTIFY YOUR SUPERVISOR" H 3 G XIT

 S APCDCODE=$P($$ICDOP^ICDEX(".9999",,,"E"),U,1)

 S APCDCODO=$P($$ICDOP^ICDEX("ZZZ999",,,"E"),U,1)

 I APCDCODE="" W !!,"ERROR -- .9999 NOT IN ICD OPERATION FILE, NOTIFY YOUR SUPERVISOR" H 3 G XIT

 I APCDCODO="" W !!,"ERROR -- ZZZ999 NOT IN ICD OPERATON FILE, NOTIFY YOUR SUPERVISOR" H 3 G XIT

 K IO("Q")

 W !!,"Enter the Device for printing"

 S %ZIS="PQ" D ^%ZIS

 I POP K IO("Q") G XIT

 I $D(IO("Q")) G TSKMN

 ;

EN ; Entry point if for taskman.

 S %DT="",X="T" D ^%DT X ^DD("DD") S APCDDT=Y

 U IO

 S APCDFILE="",APCDPG=0

 K ^TMP($J,"APCDFPPV")

 ;D HEAD

GETCODE ;

 ;

 S APCDCODE=$P($$ICDDX^ICDEX(".9999"),U,1)

 S APCDCODO=$P($$ICDDX^ICDEX("ZZZ.999"),U,1)

 I APCDWFIL="A" F APCDFILE=9000010.07,9000011,9000014,9000013 D PROC

 I APCDWFIL="POV" F APCDFILE=9000010.07 D PROC Q:$D(APCDQUIT)

 I APCDWFIL="PRB" F APCDFILE=9000011 D PROC Q:$D(APCDQUIT)

 I APCDWFIL="PHX" F APCDFILE=9000013 D PROC Q:$D(APCDQUIT)

 I APCDWFIL="FH" F APCDFILE=9000014 D PROC Q:$D(APCDQUIT)

 S APCDCODE=$P($$ICDOP^ICDEX(".9999",,,"E"),U,1)

 S APCDCODO=$P($$ICDOP^ICDEX("ZZZ999",,,"E"),U,1)

 I APCDWFIL="PRC"!(APCDWFIL="A") F APCDFILE=9000010.08 D PROC Q:$D(APCDQUIT)

 D PRINT

 S:$D(ZTQUEUED) ZTREQ="@"

 ;

XIT K APCDDOB,APCDDFN,APCDFILE,IO("Q"),APCDVDG,APCDCODE,APCDG,APCDVIGR,APCDHRN,APCDF,APCDDT,APCDL,APCDPG,APCDQUIT,ZTSK,APCDVCTR

 K AUPNSEX,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,APCDVSIT,APCDLOCT,APCDOK,APCDFUET,APCDFPPV,APCDFUDT,APCDPRVT

 K A,DX,Y,X,S,DA,D0,DIC,DIE,DIQ,DK,DL,DR,POP,D1,D2

 K ^TMP($J,"APCDFPPV")

 D ^%ZISC

 Q

CHKLOC ;

 S APCDVSIT=""

 I $L(APCDFILE)=7,APCDFILE'=9000011 S APCDOK=1 Q

 I APCDFILE=9000011 S Y=$P(^AUPNPROB(APCDDFN,0),U,6) D  Q

 .I APCDLOCT="O",Y'=APCDLOCT("ONE") S APCDOK=0 Q

 .I APCDLOCT="S",$$VALI^XBDIQ1(9999999.06,$P(^AUPNPROB(APCDDFN,0),U,6),.05)'=APCDLOCT("SU") S APCDOK=0 Q

 .S APCDOK=1

 S APCDOK=0

 S APCDG=APCDVDG_"APCDDFN,0)" S Y=$P(@APCDG,U,2),APCDVSIT=$P(@APCDG,U,3) I Y=""!(APCDVSIT="") W !,"ERROR IN GLOBAL -- NOTIFY PROGRAMMER - PATIENT OR VISIT DFN MISSING" Q

 I APCDLOCT="O",$P(^AUPNVSIT(APCDVSIT,0),U,6)'=APCDLOCT("ONE") Q

 I APCDLOCT="S",$$VALI^XBDIQ1(9999999.06,$P(^AUPNVSIT(APCDVSIT,0),U,6),.05)'=APCDLOCT("SU") Q

 S APCDOK=1

 Q

CHKPRV ;

 S APCDVSIT="" I $L(APCDFILE)=7 S APCDOK=1 Q

 S APCDOK=0

 S APCDG=APCDVDG_"APCDDFN,0)" S Y=$P(@APCDG,U,2),APCDVSIT=$P(@APCDG,U,3) I Y=""!(APCDVSIT="") W !,"ERROR IN GLOBAL -- NOTIFY PROGRAMMER - PATIENT OR VISIT DFN MISSING" Q

 I APCDPRVT="O",$$PRIMPROV^APCLV(APCDVSIT,"I")'=APCDPRVT("ONE") Q

 S APCDOK=1

 Q

O ;one community

 S DIC="^AUTTLOC(",DIC(0)="AEMQ",DIC("A")="Which LOCATION: " D ^DIC K DIC

 I Y=-1 S APCDQUIT="" Q

 S APCDLOCT("ONE")=+Y

 Q

S ;all communities within APCDSU su

 S DIC="^AUTTSU(",DIC("B")=$$VAL^XBDIQ1(9999999.06,DUZ(2),.05),DIC(0)="AEMQ",DIC("A")="Which SERVICE UNIT: " D ^DIC K DIC

 I Y=-1 S APCDQUIT="" Q

 S APCDLOCT("SU")=+Y

 Q

 ;

PROC ;

 K APCDQUIT

 S APCDDFN=""

 S APCDVDG=^DIC(APCDFILE,0,"GL")

 S APCDG=APCDVDG_"""B"",APCDCODE)"

 S APCDVIGR=APCDVDG_"""B"",APCDCODE,APCDDFN)"

 S APCDDFN=0 F  S APCDDFN=$O(@APCDVIGR) Q:APCDDFN'=+APCDDFN!($D(APCDQUIT))  S APCDOK=0 D CHKLOC I APCDOK D CHKPRV I APCDOK D PRT

 S APCDG=APCDVDG_"""B"",APCDCODO)"

 S APCDVIGR=APCDVDG_"""B"",APCDCODO,APCDDFN)"

 S APCDDFN=0 F  S APCDDFN=$O(@APCDVIGR) Q:APCDDFN'=+APCDDFN!($D(APCDQUIT))  S APCDOK=0 D CHKLOC I APCDOK D CHKPRV I APCDOK D PRT

 Q

PRT ;

 D CHKDATE I 'APCDOK Q

 I APCDFILE=9000011,$P(^AUPNPROB(APCDDFN,0),U,12)="D" Q  ;deleted

 I APCDFILE=9000011,$P($G(^AUPNPROB(APCDDFN,800)),U,1)]"" Q  ;SNOME CODED

 S ^TMP($J,"APCDFPPV",APCDFILE,APCDDFN)=""

 Q

PRINT ;

 I '$D(^TMP($J,"APCDFPPV")) D HEAD W !!,"There are no Uncoded entries." D XIT Q

 ;D HEAD

 S APCDFILE="" F  S APCDFILE=$O(^TMP($J,"APCDFPPV",APCDFILE)) Q:APCDFILE=""!($D(APCDQUIT))  D

 .D HEAD

 .Q:$D(APCDQUIT)

 .W !!,$P(^DIC(APCDFILE,0),U,1)," uncoded entries: "

 .S APCDDFN=0 F  S APCDDFN=$O(^TMP($J,"APCDFPPV",APCDFILE,APCDDFN)) Q:APCDDFN=""!($D(APCDQUIT))  D

 ..S Y=$$VALI^XBDIQ1(APCDFILE,APCDDFN,.02)

 ..S APCDVSIT="" I $L(APCDFILE)>7 S APCDVSIT=$$VALI^XBDIQ1(APCDFILE,APCDDFN,.03)

 ..D ^AUPNPAT

 ..S Y=AUPNDOB X ^DD("DD") S APCDDOB=Y

 ..S APCDHRN="" I $D(^AUPNPAT(AUPNPAT,41,DUZ(2),0)) S APCDHRN=$P(^AUPNPAT(AUPNPAT,41,DUZ(2),0),U,2)

 ..I $Y>(IOSL-7) D HEAD Q:$D(APCDQUIT)

 ..W !!,"HRN: ",APCDHRN,"     DOB: ",APCDDOB,"    SEX: ",AUPNSEX

 ..S DA=APCDDFN,DIC=^DIC(APCDFILE,0,"GL"),DR=0 D EN^DIQ K DIC,DA,DR

 ..I APCDVSIT,$L(APCDFILE)>7 S APCDVCTR=$$OPER(APCDVSIT) W ?2,"OPERATOR FROM FORMS TRACKING OR CREATED BY: " I APCDVCTR W $P(^VA(200,APCDVCTR,0),U) W !

 ..I APCDVSIT,$L(APCDFILE)>7 W ?2,"LOCATION OF ENCOUNTER: ",$$LOCENC^APCLV(APCDVSIT,"E")

 ..I APCDVSIT,$L(APCDFILE)>7 W !?2,"PROVIDER: ",$$PRIMPROV^APCLV(APCDVSIT,"N")

 ..I APCDFILE=9000011,$P($G(^AUPNPROB(APCDDFN,1)),U,4)]"" W ?2,"RECORDING PROVIDER: ",$$VAL^XBDIQ1(9000011,APCDDFN,1.04),!

 ..I APCDFILE=9000011,$P($G(^AUPNPROB(APCDDFN,1)),U,3)]"" W ?2,"ENTERED BY: ",$$VAL^XBDIQ1(9000011,APCDDFN,1.03),!

 ..I APCDFILE=9000011,$P($G(^AUPNPROB(APCDDFN,1)),U,5)]"" W !?2,"RESPONSIBLE PROVIDER: ",$$VAL^XBDIQ1(9000011,APCDDFN,1.05)

 Q

 ;

OPER(V) ;

 I $G(V)="" Q ""

 ;find operator in forms tracking first, if none return .23 of visit (user who created)

 NEW Y,D,M S Y=""

 S D=$O(^APCDFORM("AB",V,"")) I D="" Q $P(^AUPNVSIT(V,0),U,23)

 S M=$O(^APCDFORM("AB",V,D,"")) I M="" Q $P(^AUPNVSIT(V,0),U,23)

 S Y=$P(^APCDFORM(D,11,M,0),U,2)

 Q $S(Y:Y,1:$P(^AUPNVSIT(V,0),U,23))

NONE ;

 W !!,"There are no Uncoded diagnoses or procedures in the ",$P(^DIC(APCDFILE,0),U)," file."

 Q

CHKDATE ;

 S APCDOK=0

 S APCDG=APCDVDG_"APCDDFN,0)" S Y=$P(@APCDG,U,2),APCDVSIT=$P(@APCDG,U,3) I Y=""!(APCDVSIT="") W !,"ERROR IN GLOBAL -- NOTIFY PROGRAMMER - PATIENT OR VISIT DFN MISSING" Q

 I $L(APCDFILE)>7 Q:'$D(^AUPNVSIT(APCDVSIT))  I $P($P(^AUPNVSIT(APCDVSIT,0),U),".")<APCDFUDT!($P($P(^AUPNVSIT(APCDVSIT,0),U),".")>APCDFUET) Q  ;before date wanted

 I $L(APCDFILE)=7,$P(@APCDG,U,3)<APCDFUDT Q  ;quit if problem modified before date

 S APCDOK=1

 Q

HEAD ;

 I 'APCDPG G HEAD1

 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR I Y=0!($D(DTOUT)) K DIR S APCDQUIT="" Q

HEAD1 ;

 ;

 W:$D(IOF) @IOF S APCDPG=APCDPG+1

 W !,APCDDT,?70,"Page: ",APCDPG

 W !?29,"PCC Data Entry Module"

 W !?16,"***********************************************"

 W !?16,"* LISTING OF UNCODED DIAGNOSES AND PROCEDURES *"

 W !?16,"***********************************************"

 Q

SUBHEAD ;

 W !!,"Uncoded ",$P(^DIC(APCDFILE,0),U)," entries:"

 Q

TSKMN ;

 K ZTSAVE

 S ZTSAVE("APCD*")=""

 S ZTSAVE("DUZ(2)")="",ZTIO=ION,ZTCPU=$G(IOCPU),ZTRTN="EN^APCDFPPV",ZTDTH="",ZTDESC="VISIT ERROR REPORT - DATA ENTRY" D ^%ZTLOAD

 D XIT

 Q

DOC ;

 ; need to change to go thru PT node of ICD9 and 

 ; fix all files in the 9000001-9000099 range.

 ;

APCDFPPV  ; IHS/CMI/LAB - PRINT UNCODED DX ;

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

 +2       ;

LOC       ;

 +1        KILL APCDLOCT

           SET APCDLOCT=""

 +2        SET DIR(0)="S^A:ALL Locations/Facilities;S:One SERVICE UNIT'S Locations/Facilities;O:ONE Location/Facility"

           SET DIR("A")="Include Visits to Which Location/Facilities"

           SET DIR("B")="A"

 +3        SET DIR("A")="Enter a code indicating what LOCATIONS/FACILITIES are of interest"

           SET DIR("B")="O"

           KILL DA

           DO ^DIR

           KILL DIR,DA

 +4        IF $DATA(DIRUT)

               GOTO XIT

 +5        SET APCDLOCT=Y

 +6        IF APCDLOCT="A"

               GOTO DATE

 +7        DO @APCDLOCT

 +8        IF $DATA(APCDQUIT)

               GOTO LOC

DATE      ;

 +1        SET APCDFILE=9000010.07

 +2        WRITE !!,"The search for Uncoded "_$PIECE(^DIC(APCDFILE,0),U),"'s can begin at any date",!,"that you specify.  To get all of the uncoded entries enter a really early "

 +3        WRITE !,"date like 01/01/1930.  If you want to only review data for visits ",!,"in the past week, enter T-7.",!

 +4        SET APCDFUDT=""

 +5        SET DIR(0)="D^::EP"

           SET DIR("A")="Enter the Beginning Date to Search for Uncoded entries"

           KILL DA

           DO ^DIR

           KILL DIR

 +6        IF $DATA(DIRUT)

               GOTO LOC

 +7        SET APCDFUDT=Y

 +8        SET DIR(0)="D^::EP"

           SET DIR("A")="Enter the Ending Date to Search for Uncoded entries"

           KILL DA

           DO ^DIR

           KILL DIR

 +9        IF $DATA(DIRUT)

               GOTO LOC

 +10       SET APCDFUET=Y

 +11       IF APCDFUET<APCDFUDT

               WRITE !,"Ending date cannot be before beginning date."

               GOTO DATE

PROV      ;

 +1        KILL APCDPRVT

           SET APCDPRVT=""

 +2        SET DIR(0)="S^A:ALL Providers (PRIMARY);O:ONE Provider (PRIMARY)"

           SET DIR("A")="Include Visits to Which Provider"

           SET DIR("B")="A"

 +3        SET DIR("A")="Enter a code indicating what LOCATIONS/FACILITIES are of interest"

           SET DIR("B")="O"

           KILL DA

           DO ^DIR

           KILL DIR,DA

 +4        IF $DATA(DIRUT)

               GOTO XIT

 +5        SET APCDPRVT=Y

 +6        IF APCDPRVT="A"

               GOTO FILE

 +7        KILL DIC

           SET DIC("A")="Which Provider: "

           SET DIC="^VA(200,"

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC,DA

           IF X="^"

               GOTO PROV

           KILL DIC,DA

 +8        IF Y=-1

               GOTO PROV

 +9        SET APCDPRVT("ONE")=+Y

FILE      ;WHICH FILE?

 +1        SET APCDWFIL=""

 +2        SET DIR(0)="S^POV:V POV;PRB:PROBLEM LIST;PRC:V PROCEDURE;FH:FAMILY HISTORY;PHX:PERSONAL HISTORY;A:ALL OF THE ABOVE"

 +3        SET DIR("A")="Which File would like to print from"

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               GOTO PROV

 +5        SET APCDWFIL=Y

ZIS       ;

 +1        SET APCDCODE=$PIECE($$ICDDX^ICDEX(".9999"),U,1)

 +2        IF APCDCODE=""

               WRITE !!,"ERROR -- .9999 NOT IN ICD DIAGNOSIS FILE, NOTIFY YOUR SUPERVISOR"

               HANG 3

               GOTO XIT

 +3        SET APCDCODO=$PIECE($$ICDDX^ICDEX("ZZZ.999"),U,1)

 +4        IF APCDCODO=""

               WRITE !!,"ERROR -- ZZZ.999 NOT IN ICD DIAGNOSIS FILE, NOTIFY YOUR SUPERVISOR"

               HANG 3

               GOTO XIT

 +5        SET APCDCODE=$PIECE($$ICDOP^ICDEX(".9999",,,"E"),U,1)

 +6        SET APCDCODO=$PIECE($$ICDOP^ICDEX("ZZZ999",,,"E"),U,1)

 +7        IF APCDCODE=""

               WRITE !!,"ERROR -- .9999 NOT IN ICD OPERATION FILE, NOTIFY YOUR SUPERVISOR"

               HANG 3

               GOTO XIT

 +8        IF APCDCODO=""

               WRITE !!,"ERROR -- ZZZ999 NOT IN ICD OPERATON FILE, NOTIFY YOUR SUPERVISOR"

               HANG 3

               GOTO XIT

 +9        KILL IO("Q")

 +10       WRITE !!,"Enter the Device for printing"

 +11       SET %ZIS="PQ"

           DO ^%ZIS

 +12       IF POP

               KILL IO("Q")

               GOTO XIT

 +13       IF $DATA(IO("Q"))

               GOTO TSKMN

 +14      ;

EN        ; Entry point if for taskman.

 +1        SET %DT=""

           SET X="T"

           DO ^%DT

           XECUTE ^DD("DD")

           SET APCDDT=Y

 +2        USE IO

 +3        SET APCDFILE=""

           SET APCDPG=0

 +4        KILL ^TMP($JOB,"APCDFPPV")

 +5       ;D HEAD

GETCODE   ;

 +1       ;

 +2        SET APCDCODE=$PIECE($$ICDDX^ICDEX(".9999"),U,1)

 +3        SET APCDCODO=$PIECE($$ICDDX^ICDEX("ZZZ.999"),U,1)

 +4        IF APCDWFIL="A"

               FOR APCDFILE=9000010.07,9000011,9000014,9000013

                   DO PROC

 +5        IF APCDWFIL="POV"

               FOR APCDFILE=9000010.07

                   DO PROC

                   IF $DATA(APCDQUIT)

                       QUIT 

 +6        IF APCDWFIL="PRB"

               FOR APCDFILE=9000011

                   DO PROC

                   IF $DATA(APCDQUIT)

                       QUIT 

 +7        IF APCDWFIL="PHX"

               FOR APCDFILE=9000013

                   DO PROC

                   IF $DATA(APCDQUIT)

                       QUIT 

 +8        IF APCDWFIL="FH"

               FOR APCDFILE=9000014

                   DO PROC

                   IF $DATA(APCDQUIT)

                       QUIT 

 +9        SET APCDCODE=$PIECE($$ICDOP^ICDEX(".9999",,,"E"),U,1)

 +10       SET APCDCODO=$PIECE($$ICDOP^ICDEX("ZZZ999",,,"E"),U,1)

 +11       IF APCDWFIL="PRC"!(APCDWFIL="A")

               FOR APCDFILE=9000010.08

                   DO PROC

                   IF $DATA(APCDQUIT)

                       QUIT 

 +12       DO PRINT

 +13       IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +14      ;

XIT        KILL APCDDOB,APCDDFN,APCDFILE,IO("Q"),APCDVDG,APCDCODE,APCDG,APCDVIGR,APCDHRN,APCDF,APCDDT,APCDL,APCDPG,APCDQUIT,ZTSK,APCDVCTR

 +1        KILL AUPNSEX,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,APCDVSIT,APCDLOCT,APCDOK,APCDFUET,APCDFPPV,APCDFUDT,APCDPRVT

 +2        KILL A,DX,Y,X,S,DA,D0,DIC,DIE,DIQ,DK,DL,DR,POP,D1,D2

 +3        KILL ^TMP($JOB,"APCDFPPV")

 +4        DO ^%ZISC

 +5        QUIT 

CHKLOC    ;

 +1        SET APCDVSIT=""

 +2        IF $LENGTH(APCDFILE)=7

               IF APCDFILE'=9000011

                   SET APCDOK=1

                   QUIT 

 +3        IF APCDFILE=9000011

               SET Y=$PIECE(^AUPNPROB(APCDDFN,0),U,6)

               Begin DoDot:1

 +4                IF APCDLOCT="O"

                       IF Y'=APCDLOCT("ONE")

                           SET APCDOK=0

                           QUIT 

 +5                IF APCDLOCT="S"

                       IF $$VALI^XBDIQ1(9999999.06,$PIECE(^AUPNPROB(APCDDFN,0),U,6),.05)'=APCDLOCT("SU")

                           SET APCDOK=0

                           QUIT 

 +6                SET APCDOK=1

               End DoDot:1

               QUIT 

 +7        SET APCDOK=0

 +8        SET APCDG=APCDVDG_"APCDDFN,0)"

           SET Y=$PIECE(@APCDG,U,2)

           SET APCDVSIT=$PIECE(@APCDG,U,3)

           IF Y=""!(APCDVSIT="")

               WRITE !,"ERROR IN GLOBAL -- NOTIFY PROGRAMMER - PATIENT OR VISIT DFN MISSING"

               QUIT 

 +9        IF APCDLOCT="O"

               IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,6)'=APCDLOCT("ONE")

                   QUIT 

 +10       IF APCDLOCT="S"

               IF $$VALI^XBDIQ1(9999999.06,$PIECE(^AUPNVSIT(APCDVSIT,0),U,6),.05)'=APCDLOCT("SU")

                   QUIT 

 +11       SET APCDOK=1

 +12       QUIT 

CHKPRV    ;

 +1        SET APCDVSIT=""

           IF $LENGTH(APCDFILE)=7

               SET APCDOK=1

               QUIT 

 +2        SET APCDOK=0

 +3        SET APCDG=APCDVDG_"APCDDFN,0)"

           SET Y=$PIECE(@APCDG,U,2)

           SET APCDVSIT=$PIECE(@APCDG,U,3)

           IF Y=""!(APCDVSIT="")

               WRITE !,"ERROR IN GLOBAL -- NOTIFY PROGRAMMER - PATIENT OR VISIT DFN MISSING"

               QUIT 

 +4        IF APCDPRVT="O"

               IF $$PRIMPROV^APCLV(APCDVSIT,"I")'=APCDPRVT("ONE")

                   QUIT 

 +5        SET APCDOK=1

 +6        QUIT 

O         ;one community

 +1        SET DIC="^AUTTLOC("

           SET DIC(0)="AEMQ"

           SET DIC("A")="Which LOCATION: "

           DO ^DIC

           KILL DIC

 +2        IF Y=-1

               SET APCDQUIT=""

               QUIT 

 +3        SET APCDLOCT("ONE")=+Y

 +4        QUIT 

S         ;all communities within APCDSU su

 +1        SET DIC="^AUTTSU("

           SET DIC("B")=$$VAL^XBDIQ1(9999999.06,DUZ(2),.05)

           SET DIC(0)="AEMQ"

           SET DIC("A")="Which SERVICE UNIT: "

           DO ^DIC

           KILL DIC

 +2        IF Y=-1

               SET APCDQUIT=""

               QUIT 

 +3        SET APCDLOCT("SU")=+Y

 +4        QUIT 

 +5       ;

PROC      ;

 +1        KILL APCDQUIT

 +2        SET APCDDFN=""

 +3        SET APCDVDG=^DIC(APCDFILE,0,"GL")

 +4        SET APCDG=APCDVDG_"""B"",APCDCODE)"

 +5        SET APCDVIGR=APCDVDG_"""B"",APCDCODE,APCDDFN)"

 +6        SET APCDDFN=0

           FOR 

               SET APCDDFN=$ORDER(@APCDVIGR)

               IF APCDDFN'=+APCDDFN!($DATA(APCDQUIT))

                   QUIT 

               SET APCDOK=0

               DO CHKLOC

               IF APCDOK

                   DO CHKPRV

                   IF APCDOK

                       DO PRT

 +7        SET APCDG=APCDVDG_"""B"",APCDCODO)"

 +8        SET APCDVIGR=APCDVDG_"""B"",APCDCODO,APCDDFN)"

 +9        SET APCDDFN=0

           FOR 

               SET APCDDFN=$ORDER(@APCDVIGR)

               IF APCDDFN'=+APCDDFN!($DATA(APCDQUIT))

                   QUIT 

               SET APCDOK=0

               DO CHKLOC

               IF APCDOK

                   DO CHKPRV

                   IF APCDOK

                       DO PRT

 +10       QUIT 

PRT       ;

 +1        DO CHKDATE

           IF 'APCDOK

               QUIT 

 +2       ;deleted

           IF APCDFILE=9000011

               IF $PIECE(^AUPNPROB(APCDDFN,0),U,12)="D"

                   QUIT 

 +3       ;SNOME CODED

           IF APCDFILE=9000011

               IF $PIECE($GET(^AUPNPROB(APCDDFN,800)),U,1)]""

                   QUIT 

 +4        SET ^TMP($JOB,"APCDFPPV",APCDFILE,APCDDFN)=""

 +5        QUIT 

PRINT     ;

 +1        IF '$DATA(^TMP($JOB,"APCDFPPV"))

               DO HEAD

               WRITE !!,"There are no Uncoded entries."

               DO XIT

               QUIT 

 +2       ;D HEAD

 +3        SET APCDFILE=""

           FOR 

               SET APCDFILE=$ORDER(^TMP($JOB,"APCDFPPV",APCDFILE))

               IF APCDFILE=""!($DATA(APCDQUIT))

                   QUIT 

               Begin DoDot:1

 +4                DO HEAD

 +5                IF $DATA(APCDQUIT)

                       QUIT 

 +6                WRITE !!,$PIECE(^DIC(APCDFILE,0),U,1)," uncoded entries: "

 +7                SET APCDDFN=0

                   FOR 

                       SET APCDDFN=$ORDER(^TMP($JOB,"APCDFPPV",APCDFILE,APCDDFN))

                       IF APCDDFN=""!($DATA(APCDQUIT))

                           QUIT 

                       Begin DoDot:2

 +8                        SET Y=$$VALI^XBDIQ1(APCDFILE,APCDDFN,.02)

 +9                        SET APCDVSIT=""

                           IF $LENGTH(APCDFILE)>7

                               SET APCDVSIT=$$VALI^XBDIQ1(APCDFILE,APCDDFN,.03)

 +10                       DO ^AUPNPAT

 +11                       SET Y=AUPNDOB

                           XECUTE ^DD("DD")

                           SET APCDDOB=Y

 +12                       SET APCDHRN=""

                           IF $DATA(^AUPNPAT(AUPNPAT,41,DUZ(2),0))

                               SET APCDHRN=$PIECE(^AUPNPAT(AUPNPAT,41,DUZ(2),0),U,2)

 +13                       IF $Y>(IOSL-7)

                               DO HEAD

                               IF $DATA(APCDQUIT)

                                   QUIT 

 +14                       WRITE !!,"HRN: ",APCDHRN,"     DOB: ",APCDDOB,"    SEX: ",AUPNSEX

 +15                       SET DA=APCDDFN

                           SET DIC=^DIC(APCDFILE,0,"GL")

                           SET DR=0

                           DO EN^DIQ

                           KILL DIC,DA,DR

 +16                       IF APCDVSIT

                               IF $LENGTH(APCDFILE)>7

                                   SET APCDVCTR=$$OPER(APCDVSIT)

                                   WRITE ?2,"OPERATOR FROM FORMS TRACKING OR CREATED BY: "

                                   IF APCDVCTR

                                       WRITE $PIECE(^VA(200,APCDVCTR,0),U)

                                       WRITE !

 +17                       IF APCDVSIT

                               IF $LENGTH(APCDFILE)>7

                                   WRITE ?2,"LOCATION OF ENCOUNTER: ",$$LOCENC^APCLV(APCDVSIT,"E")

 +18                       IF APCDVSIT

                               IF $LENGTH(APCDFILE)>7

                                   WRITE !?2,"PROVIDER: ",$$PRIMPROV^APCLV(APCDVSIT,"N")

 +19                       IF APCDFILE=9000011

                               IF $PIECE($GET(^AUPNPROB(APCDDFN,1)),U,4)]""

                                   WRITE ?2,"RECORDING PROVIDER: ",$$VAL^XBDIQ1(9000011,APCDDFN,1.04),!

 +20                       IF APCDFILE=9000011

                               IF $PIECE($GET(^AUPNPROB(APCDDFN,1)),U,3)]""

                                   WRITE ?2,"ENTERED BY: ",$$VAL^XBDIQ1(9000011,APCDDFN,1.03),!

 +21                       IF APCDFILE=9000011

                               IF $PIECE($GET(^AUPNPROB(APCDDFN,1)),U,5)]""

                                   WRITE !?2,"RESPONSIBLE PROVIDER: ",$$VAL^XBDIQ1(9000011,APCDDFN,1.05)

                       End DoDot:2

               End DoDot:1

 +22       QUIT 

 +23      ;

OPER(V)   ;

 +1        IF $GET(V)=""

               QUIT ""

 +2       ;find operator in forms tracking first, if none return .23 of visit (user who created)

 +3        NEW Y,D,M

           SET Y=""

 +4        SET D=$ORDER(^APCDFORM("AB",V,""))

           IF D=""

               QUIT $PIECE(^AUPNVSIT(V,0),U,23)

 +5        SET M=$ORDER(^APCDFORM("AB",V,D,""))

           IF M=""

               QUIT $PIECE(^AUPNVSIT(V,0),U,23)

 +6        SET Y=$PIECE(^APCDFORM(D,11,M,0),U,2)

 +7        QUIT $SELECT(Y:Y,1:$PIECE(^AUPNVSIT(V,0),U,23))

NONE      ;

 +1        WRITE !!,"There are no Uncoded diagnoses or procedures in the ",$PIECE(^DIC(APCDFILE,0),U)," file."

 +2        QUIT 

CHKDATE   ;

 +1        SET APCDOK=0

 +2        SET APCDG=APCDVDG_"APCDDFN,0)"

           SET Y=$PIECE(@APCDG,U,2)

           SET APCDVSIT=$PIECE(@APCDG,U,3)

           IF Y=""!(APCDVSIT="")

               WRITE !,"ERROR IN GLOBAL -- NOTIFY PROGRAMMER - PATIENT OR VISIT DFN MISSING"

               QUIT 

 +3       ;before date wanted

           IF $LENGTH(APCDFILE)>7

               IF '$DATA(^AUPNVSIT(APCDVSIT))

                   QUIT 

               IF $PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")<APCDFUDT!($PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")>APCDFUET)

                   QUIT 

 +4       ;quit if problem modified before date

           IF $LENGTH(APCDFILE)=7

               IF $PIECE(@APCDG,U,3)<APCDFUDT

                   QUIT 

 +5        SET APCDOK=1

 +6        QUIT 

HEAD      ;

 +1        IF 'APCDPG

               GOTO HEAD1

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

               IF IO=IO(0)

                   WRITE !

                   SET DIR(0)="EO"

                   DO ^DIR

                   IF Y=0!($DATA(DTOUT))

                       KILL DIR

                       SET APCDQUIT=""

                       QUIT 

HEAD1     ;

 +1       ;

 +2        IF $DATA(IOF)

               WRITE @IOF

           SET APCDPG=APCDPG+1

 +3        WRITE !,APCDDT,?70,"Page: ",APCDPG

 +4        WRITE !?29,"PCC Data Entry Module"

 +5        WRITE !?16,"***********************************************"

 +6        WRITE !?16,"* LISTING OF UNCODED DIAGNOSES AND PROCEDURES *"

 +7        WRITE !?16,"***********************************************"

 +8        QUIT 

SUBHEAD   ;

 +1        WRITE !!,"Uncoded ",$PIECE(^DIC(APCDFILE,0),U)," entries:"

 +2        QUIT 

TSKMN     ;

 +1        KILL ZTSAVE

 +2        SET ZTSAVE("APCD*")=""

 +3        SET ZTSAVE("DUZ(2)")=""

           SET ZTIO=ION

           SET ZTCPU=$GET(IOCPU)

           SET ZTRTN="EN^APCDFPPV"

           SET ZTDTH=""

           SET ZTDESC="VISIT ERROR REPORT - DATA ENTRY"

           DO ^%ZTLOAD

 +4        DO XIT

 +5        QUIT 

DOC       ;

 +1       ; need to change to go thru PT node of ICD9 and 

 +2       ; fix all files in the 9000001-9000099 range.

 +3       ;