APCDCAFJ.m

APCDCAFJ ; IHS/CMI/LAB - MENTAL HLTH ROUTINE 16-AUG-1994 ;

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

 ;; ;

 ;

PROCESS ;EP

 S APCDJ=$J,APCDH=$H

 S ^XTMP("APCDCAFI",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"PCC CODING INCOMPLETE VISITS REPORT"

 S APCDODAT=$P(APCDBD,".")-1,APCDODAT=APCDODAT_".9999"

 S (APCDRCNT,APCDVIEN)=0 F  S APCDODAT=$O(^AUPNVSIT("B",APCDODAT)) Q:APCDODAT=""!($P(APCDODAT,".")>$P(APCDED,"."))  D

 .S APCDVIEN=0 F  S APCDVIEN=$O(^AUPNVSIT("B",APCDODAT,APCDVIEN)) Q:APCDVIEN'=+APCDVIEN  D

 ..S APCDV0=$G(^AUPNVSIT(APCDVIEN,0))

 ..Q:APCDV0=""

N ..;

 ..Q:'$P(APCDV0,U,9)        ;NO DEP ENTRIES

 ..Q:$P(APCDV0,U,11)        ;DELETED

 ..Q:$P(APCDV0,U,3)="C"     ;CONTRACT

 ..S APCDVCAS=$P($G(^AUPNVSIT(APCDVIEN,11)),U,11)

 ..I APCDVCAS'="I" Q  ;ONLY INCOMPLETE VISITS

 ..S APCDVPP=$$PRIMPROV^APCLV(APCDVIEN,"I")

 ..S APCDVLOC=$P(APCDV0,U,6)

 ..Q:APCDVLOC=""  ;no location of encounter

 ..I $D(APCDLOCS),'$D(APCDLOCS(APCDVLOC)) Q  ;not a location we want

 ..S APCDVCLN=$P(APCDV0,U,8)

 ..I APCDVCLN="",$D(APCDCLNS) Q  ;clinic blank and want certain clinics

 ..I $D(APCDCLNS),'$D(APCDCLNS(APCDVCLN)) Q  ;not a CLINIC we want

 ..S APCDVHL=$P(APCDV0,U,22)

 ..I APCDVHL="",$D(APCDHLS) Q

 ..I $D(APCDHLS),'$D(APCDHLS(APCDVHL)) Q  ;not a HOSP LOC we want

 ..I APCDVPP="",$D(APCDPRVS) Q

 ..I $D(APCDPRVS),'$D(APCDPRVS(APCDVPP)) Q  ;not a PRIM PROV we want

 ..K APCDVCDR D GETVCDR^APCDCAFS(APCDVIEN,"APCDVCDR")  ;GET ALL PENDING REASONS

 ..I '$D(APCDVCDR),$D(APCDCDRS) Q  ;

 ..S G=0 I $D(APCDCDRS) D

 ...S X=0 F  S X=$O(APCDVCDR(X)) Q:X'=+X  I $D(APCDCDRS(X)) S G=1

 ..I $D(APCDCDRS),'G Q

 ..S ^XTMP("APCDCAFI",APCDJ,APCDH,"VISITS",$$SORT(APCDVIEN,APCDSORT),APCDVIEN)=""

 .Q

 Q

 ;

DATE(D) ;

 NEW X,Y

 S X=$P(D,".")

 S X=$E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)

 S Y=$$FMTE^XLFDT(D,"2S"),Y=$P(Y,"@",2),Y=$P(Y,":",1,2)

 Q X_"@"_Y

 ;

ERRORCHK ;

 ;check for no pov, .9999 or multiple primary providers

 S APCDERR=""

 I '$D(^AUPNVPOV("AD",APCDV)) S APCDERR="NO POV"

 S X=0 F  S X=$O(^AUPNVPOV("AD",APCDV,X)) Q:X'=+X  D

 .I $$VAL^XBDIQ1(9000010.07,X,.01)=".9999" S APCDERR=".9999 POV " Q

 .I $$VAL^XBDIQ1(9000010.07,X,.01)="ZZZ.999" S APCDERR="ZZZ.999 POV "

 S X=0,C=0 F  S X=$O(^AUPNVPRV("AD",APCDV,X)) Q:X'=+X  D

 .I $P(^AUPNVPRV(X,0),U,4)="P" S C=C+1

 I C>1 S APCDERR=APCDERR_"MULT PRIM PROV"

 Q

RBLK(V,L) ;left blank fill

 NEW %,I

 S %=$L(V),Z=L-% F I=1:1:Z S V=V_" "

 Q V

LBLK(V,L) ;left blank fill

 NEW %,I

 S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V

 Q V

 ;

LASTCDR(V,F) ;EP - get last chart deficiency reason

 I $G(F)="" S F="I"  ;default to ien

 I '$D(^AUPNVCA("AD",V)) Q ""

 NEW X,A,D,L

 S X=0 F  S X=$O(^AUPNVCA("AD",V,X)) Q:X'=+X  D

 .Q:'$D(^AUPNVCA(X,0))

 .S D=$P(^AUPNVCA(X,0),U)

 .S A((9999999-$P(D,".")))=X

 S L=$O(A(0)) I L="" Q ""

 S L=A(L)

 Q $S(F="I":$P(^AUPNVCA(L,0),U,6),1:$$VAL^XBDIQ1(9000010.45,L,.06))

 ;

SORT(V,S) ;

 NEW R

 S R=""

 D @(S_"SORT")

 I R="" S R="--"

 Q R

 ;

DSORT ;

 I 'V Q ""

 I '$D(^AUPNVSIT(V,0)) Q ""

 S R=$P(^AUPNVSIT(V,0),U)

 Q

 ;

SSORT ;

 I 'V Q ""

 I '$D(^AUPNVSIT(V,0)) Q ""

 S R=$$VAL^XBDIQ1(9000010,V,.07)

 Q

 ;

LSORT ;

 I 'V Q ""

 I '$D(^AUPNVSIT(V,0)) Q ""

 S R=$$VAL^XBDIQ1(9000010,V,.06)

 Q

 ;

CSORT ;

 I 'V Q ""

 I '$D(^AUPNVSIT(V,0)) Q ""

 S R=$$VAL^XBDIQ1(9000010,V,.08)

 Q

 ;

OSORT ;

 I 'V Q ""

 I '$D(^AUPNVSIT(V,0)) Q ""

 S R=$$VAL^XBDIQ1(9000010,V,.22)

 Q

 ;

PSORT ;

 S R=$$PRIMPROV^APCLV(V,"N")

 Q

 ;

ASORT ;

 I 'V Q ""

 I '$D(^AUPNVSIT(V,0)) Q ""

 S R=$$VAL^XBDIQ1(9000010,V,1111)

 I R="" S R="INCOMPLETE"

 Q

 ;

RSORT ;

 S R=$$LASTCDR(V,"E")

 Q

 ;

NSORT ;

 S R=$$VAL^XBDIQ1(9000010,V,.05)

 Q

 ;

HSORT ;

 S R=$$HRN^AUPNPAT($P(^AUPNVSIT(V,0),U,5),DUZ(2))

 Q

 ;

TSORT ;

 I V="" Q

 I '$D(^AUPNVSIT(V,0)) Q ""

 NEW D

 S D=$P(^AUPNVSIT(V,0),U,5)

 I D="" Q

 S R=$$HRN^AUPNPAT(D,DUZ(2))

 S R=R+10000000,R=$E(R,7,8)_$E(R,1,6)

 Q

 ;

EOP ;EP - End of page.

 Q:$E(IOST)'="C"

 NEW DIR

 K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT

 S DIR("A")="Press Enter to Continue",DIR(0)="E" D ^DIR

 Q

 ;----------

PRINT ;EP - called from xbdbque

 S APCD80S="-------------------------------------------------------------------------------"

 S Y=APCDBD D DD^%DT S APCDBDD=Y S Y=APCDED D DD^%DT S APCDEDD=Y

 S APCDPG=0

 K APCDQUIT

 D COVPAGE

 D PRINT1

DONE ;

 I $D(APCDQUIT) G XIT

 I $D(APCDET) S APCDDVTS=(86400*($P(APCDET,",")-$P(APCDBT,",")))+($P(APCDET,",",2)-$P(APCDBT,",",2)),APCDDVH=$P(APCDDVTS/3600,".") S:APCDDVH="" APCDDVH=0

 S APCDDVTS=APCDDVTS-(APCDDVH*3600),APCDDVM=$P(APCDDVTS/60,".") S:APCDDVM="" APCDDVM=0 S APCDDVTS=APCDDVTS-(APCDDVM*60),APCDDVS=APCDDVTS W !!,"RUN TIME (H.M.S): ",APCDDVH,".",APCDDVM,".",APCDDVS

 I $E(IOST)="C",IO=IO(0) S DIR(0)="E" D ^DIR K DIR

 W:$D(IOF) @IOF

XIT ; Clean up and exit

 K ^XTMP("APCDCAFI",APCDJ,APCDH,"VISITS")

 D EN^XBVK("APCD")

 Q

PRINT1 ; Print report 2

 K APCDQUIT

 D HEAD

 I '$D(^XTMP("APCDCAFI",APCDJ,APCDH,"VISITS")) W !!,"There are no visits that are not already reviewed." Q

 S APCDS="" F  S APCDS=$O(^XTMP("APCDCAFI",APCDJ,APCDH,"VISITS",APCDS)) Q:APCDS=""!($D(APCDQUIT))  D

 .S APCDV="" F  S APCDV=$O(^XTMP("APCDCAFI",APCDJ,APCDH,"VISITS",APCDS,APCDV)) Q:APCDV=""!($D(APCDQUIT))  D

 ..D PRN1

 ..Q:$D(APCDQUIT)

 ..D DE

 ..Q:$D(APCDQUIT)

 ..D NOTES

 ..W !

 ..D ER

 Q

ER ; CHECK FOR VARIOUS ERRORS

 ;no pov, no prov, .9999, multi prim prov, 

 Q

DE ;EP;FIND DEP ENTRIES

 S APCDP="This visit has: "

 S APCDVFLE=9000010 F  S APCDVFLE=$O(^DIC(APCDVFLE)) Q:APCDVFLE>9000010.99!(APCDVFLE'=+APCDVFLE)!($D(APCDQUIT))  D DE2

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

 W !?1,APCDP

 Q

 ;

DE2 ;

 Q:APCDVFLE=9000010.45  ;DON'T DISPLAY CHART AUDIT V FILE

 S APCDVDG=^DIC(APCDVFLE,0,"GL"),APCDVIGR=APCDVDG_"""AD"",APCDV,APCDVDFN)"

 S APCDVDFN="" I $O(@APCDVIGR)]"" D

 .S APCDP=APCDP_$P($P(^DIC(APCDVFLE,0),U),"V ",2)_"s "

 Q

 ;

PRN1 ;EP

 S APCDVR=^AUPNVSIT(APCDV,0) S:'$P(APCDVR,U,6) $P(APCDVR,U,6)=0

 S DFN=$P(APCDVR,U,5)

 S APCDHRN="" S APCDHRN=$$HRN^AUPNPAT(DFN,$P(APCDVR,U,6),2)

 I APCDHRN="" S APCDHRN=$$HRN^AUPNPAT(DFN,DUZ(2))

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

 W !,$$FMTE^XLFDT($P(APCDVR,U)),?19,APCDHRN,?31,$E($P(^DPT(DFN,0),U),1,17),?50,$E($P(^DIC(4,$P(APCDVR,U,6),0),U),1,10),?61,$P(APCDVR,U,7)

 W ?64,$$CLINIC^APCLV(APCDV,"C"),?67,$E($$VAL^XBDIQ1(9000010,APCDV,.22),1,11),?78,$P(APCDVR,U,9)

 W:$$PRIMPROV^APCLV(APCDV,"N")]"" !," PRIMARY PROVIDER: ",$$PRIMPROV^APCLV(APCDV,"N")

 I $P($G(^AUPNVSIT(APCDV,12)),U,11)]"" W !," Ext Acct #: ",$P($G(^AUPNVSIT(APCDV,12)),U,11)

 Q

NOTES ;

 W !?1," Pending Deficiencies:"

 S APCDG=0,APCDN1=0 F  S APCDN1=$O(^AUPNCANT(APCDV,12,APCDN1)) Q:'APCDN1  D

 . S IENS=APCDN1_","_APCDV

 . I $$GET1^DIQ(9000095.12,IENS,.03)]"" Q

 . I $$GET1^DIQ(9000095.12,IENS,.08)]"" Q

 . ;

 . S PROV=$$GET1^DIQ(9000095.12,IENS,.01,"I")             ;provider IEN

 . S PROVN=$$GET1^DIQ(9000095.12,IENS,.01)                ;provider name

 . ;

 . S LINE=" "_$$PAD^APCDCAF6($E(PROVN,1,22),25)_$$GET1^DIQ(9000095.12,IENS,.02)   ;provider & deficiency

 . S LINE=$$PAD^APCDCAF6(LINE,60)_$$GET1^DIQ(9000095.12,IENS,.11)           ;resolution status

 . W !,LINE S APCDG=1

 . S LINE=" "_$$PAD^APCDCAF6("Entered by: "_$$GET1^DIQ(9000095.12,IENS,.05),50)_"Date Entered: "_$$GET1^DIQ(9000095.12,IENS,.04)

 . W !,LINE

 . ;

 I 'APCDG W "  None Recorded"

 ;NOW OLD ONES

 S APCDX=0,APCDC=0 F  S APCDX=$O(^AUPNVCA("AD",APCDV,APCDX)) Q:APCDX'=+APCDX!($D(APCDQUIT))  D

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

 .S APCDC=APCDC+1 I APCDC=1 W !?1,"Status Update",?27,"User" ;,?45,"Chart Deficiency Reason(s)"

 .W !?1,$$FMTE^XLFDT($P($P(^AUPNVCA(APCDX,0),U,1),"."),5),?12,$E($$VAL^XBDIQ1(9000010.45,APCDX,.04),1,12),?27,$E($$VAL^XBDIQ1(9000010.45,APCDX,.05),1,15),?45,$E($$VAL^XBDIQ1(9000010.45,APCDX,.06),1,21)

 K ^UTILITY($J,"W")

 S APCDNDA=$O(^AUPNCANT("B",APCDV,0)) Q:'APCDNDA

 Q:'$O(^AUPNCANT(APCDNDA,11,0))

WP ;

 K ^UTILITY($J,"W")

 S APCDX=0

 S DIWL=10,DIWR=80,DIWF="" F  S APCDX=$O(^AUPNCANT(APCDNDA,11,APCDX)) Q:APCDX'=+APCDX  D

 .S X=^AUPNCANT(APCDNDA,11,APCDX,0) D ^DIWP

 .Q

 ;D ^DIWW

WPS ;

 S APCDX=0,APCDC=0 F  S APCDX=$O(^UTILITY($J,"W",DIWL,APCDX)) Q:APCDX'=+APCDX!($D(APCDQUIT))  D

 .S APCDC=APCDC+1

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

 .I APCDC=1 W !?1,"Notes: ",?8,^UTILITY($J,"W",DIWL,APCDX,0)

 .W:APCDC'=1 !?8,^UTILITY($J,"W",DIWL,APCDX,0)

 K DIWL,DIWR,DIWF,APCDX

 K ^UTILITY($J,"W"),APCDX,APCDNDA

 Q

PAGEHEAD ;

HEAD ;EP;HEADER

 G:$D(APCDDEM)!($D(APCDDEMM)) HEAD2

 I 'APCDPG G HEAD1

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

HEAD1 ;

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

 W !,$$FMTE^XLFDT(DT),?70,"Page: ",APCDPG

 W !?29,"PCC Data Entry Module"

 W !,$$CTR("******************************************************************",80)

 W !,$$CTR("*      LIST OF VISITS WITH CHART AUDIT STATUS OF INCOMPLETE      *",80)

 W !,$$CTR("******************************************************************",80)

 S X="VISIT Date Range: "_APCDBDD_" through "_APCDEDD W !,$$CTR(X,80)

 W !!,"VISIT DATE",?19,"HRN",?31,"PATIENT NAME",?50,"LOCATION",?61,"SC",?64,"CL",?67,"HOSP LOC",?77,"DEC"

 W !,APCD80S

 Q

CTR(X,Y) ;EP

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

 ;----------

COVPAGE ;

 W !,$$FMTE^XLFDT(DT),?70,"Page: ",APCDPG

 W !?29,"PCC Data Entry Module"

 W !,$$CTR("******************************************************************",80)

 W !,$$CTR("*      LIST OF VISITS WITH CHART AUDIT STATUS OF INCOMPLETE      *",80)

 W !,$$CTR("******************************************************************",80)

 W !!,$$CTR("VISIT LIST CRITERIA",80)

 W !!,"VISIT DATES: ",$$FMTE^XLFDT(APCDBD)," to ",$$FMTE^XLFDT(APCDED)

 W !,"VISIT TYPE:  NOT Contract"

 W !!,"LOCATION OF ENCOUNTER: " D

 .I '$D(APCLLOCS) W "All" Q

 .S Y=0,C=0 F  S Y=$O(APCDLOCS(Y)) Q:Y'=+Y  S C=C+1 W:C>1 ";" W ?24,$E($P(^DIC(4,Y,0),U),1,15)

 W !!,"CLINICS: " D

 .I '$D(APCLCLNS) W "All" Q

 .S Y=0,C=0 F  S Y=$O(APCDCLNS(Y)) Q:Y'=+Y  S C=C+1 W:C>1 ";" W ?24,$E($P(^DIC(40.7,Y,0),U),1,15)

 W !!,"HOSPITAL LOCATIONS: " D

 .I '$D(APCLHLS) W "All" Q

 .S Y=0,C=0 F  S Y=$O(APCDHLS(Y)) Q:Y'=+Y  S C=C+1 W:C>1 ";" W ?24,$E($P(^SC(Y,0),U),1,15)

 W !!,"PRIMARY PROVIDER ON VISIT: " D

 .I '$D(APCLPRV) W "All" Q

 .S Y=0,C=0 F  S Y=$O(APCDPRVS(Y)) Q:Y'=+Y  S C=C+1 W:C>1 ";" W ?24,$E($P(^VA(200,Y,0),U),1,15)

 W !!,"CHART DEFICIENCY REASONS: " D

 .I '$D(APCLCDRS) W "All (includes visits with no chart deficiency reason entered" Q

 .S Y=0,C=0 F  S Y=$O(APCDCDRS(Y)) Q:Y'=+Y  S C=C+1 W:C>1 ";" W ?24,$E($P(^AUTTCDR(Y,0),U),1,15)

 Q

APCDCAFJ  ; IHS/CMI/LAB - MENTAL HLTH ROUTINE 16-AUG-1994 ;

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

 +2       ;; ;

 +3       ;

PROCESS   ;EP

 +1        SET APCDJ=$JOB

           SET APCDH=$HOROLOG

 +2        SET ^XTMP("APCDCAFI",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"PCC CODING INCOMPLETE VISITS REPORT"

 +3        SET APCDODAT=$PIECE(APCDBD,".")-1

           SET APCDODAT=APCDODAT_".9999"

 +4        SET (APCDRCNT,APCDVIEN)=0

           FOR 

               SET APCDODAT=$ORDER(^AUPNVSIT("B",APCDODAT))

               IF APCDODAT=""!($PIECE(APCDODAT,".")>$PIECE(APCDED,"."))

                   QUIT 

               Begin DoDot:1

 +5                SET APCDVIEN=0

                   FOR 

                       SET APCDVIEN=$ORDER(^AUPNVSIT("B",APCDODAT,APCDVIEN))

                       IF APCDVIEN'=+APCDVIEN

                           QUIT 

                       Begin DoDot:2

 +6                        SET APCDV0=$GET(^AUPNVSIT(APCDVIEN,0))

 +7                        IF APCDV0=""

                               QUIT 

N         ;

 +1       ;NO DEP ENTRIES

                           IF '$PIECE(APCDV0,U,9)

                               QUIT 

 +2       ;DELETED

                           IF $PIECE(APCDV0,U,11)

                               QUIT 

 +3       ;CONTRACT

                           IF $PIECE(APCDV0,U,3)="C"

                               QUIT 

 +4                        SET APCDVCAS=$PIECE($GET(^AUPNVSIT(APCDVIEN,11)),U,11)

 +5       ;ONLY INCOMPLETE VISITS

                           IF APCDVCAS'="I"

                               QUIT 

 +6                        SET APCDVPP=$$PRIMPROV^APCLV(APCDVIEN,"I")

 +7                        SET APCDVLOC=$PIECE(APCDV0,U,6)

 +8       ;no location of encounter

                           IF APCDVLOC=""

                               QUIT 

 +9       ;not a location we want

                           IF $DATA(APCDLOCS)

                               IF '$DATA(APCDLOCS(APCDVLOC))

                                   QUIT 

 +10                       SET APCDVCLN=$PIECE(APCDV0,U,8)

 +11      ;clinic blank and want certain clinics

                           IF APCDVCLN=""

                               IF $DATA(APCDCLNS)

                                   QUIT 

 +12      ;not a CLINIC we want

                           IF $DATA(APCDCLNS)

                               IF '$DATA(APCDCLNS(APCDVCLN))

                                   QUIT 

 +13                       SET APCDVHL=$PIECE(APCDV0,U,22)

 +14                       IF APCDVHL=""

                               IF $DATA(APCDHLS)

                                   QUIT 

 +15      ;not a HOSP LOC we want

                           IF $DATA(APCDHLS)

                               IF '$DATA(APCDHLS(APCDVHL))

                                   QUIT 

 +16                       IF APCDVPP=""

                               IF $DATA(APCDPRVS)

                                   QUIT 

 +17      ;not a PRIM PROV we want

                           IF $DATA(APCDPRVS)

                               IF '$DATA(APCDPRVS(APCDVPP))

                                   QUIT 

 +18      ;GET ALL PENDING REASONS

                           KILL APCDVCDR

                           DO GETVCDR^APCDCAFS(APCDVIEN,"APCDVCDR")

 +19      ;

                           IF '$DATA(APCDVCDR)

                               IF $DATA(APCDCDRS)

                                   QUIT 

 +20                       SET G=0

                           IF $DATA(APCDCDRS)

                               Begin DoDot:3

 +21                               SET X=0

                                   FOR 

                                       SET X=$ORDER(APCDVCDR(X))

                                       IF X'=+X

                                           QUIT 

                                       IF $DATA(APCDCDRS(X))

                                           SET G=1

                               End DoDot:3

 +22                       IF $DATA(APCDCDRS)

                               IF 'G

                                   QUIT 

 +23                       SET ^XTMP("APCDCAFI",APCDJ,APCDH,"VISITS",$$SORT(APCDVIEN,APCDSORT),APCDVIEN)=""

                       End DoDot:2

 +24               QUIT 

               End DoDot:1

 +25       QUIT 

 +26      ;

DATE(D)   ;

 +1        NEW X,Y

 +2        SET X=$PIECE(D,".")

 +3        SET X=$EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)

 +4        SET Y=$$FMTE^XLFDT(D,"2S")

           SET Y=$PIECE(Y,"@",2)

           SET Y=$PIECE(Y,":",1,2)

 +5        QUIT X_"@"_Y

 +6       ;

ERRORCHK  ;

 +1       ;check for no pov, .9999 or multiple primary providers

 +2        SET APCDERR=""

 +3        IF '$DATA(^AUPNVPOV("AD",APCDV))

               SET APCDERR="NO POV"

 +4        SET X=0

           FOR 

               SET X=$ORDER(^AUPNVPOV("AD",APCDV,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +5                IF $$VAL^XBDIQ1(9000010.07,X,.01)=".9999"

                       SET APCDERR=".9999 POV "

                       QUIT 

 +6                IF $$VAL^XBDIQ1(9000010.07,X,.01)="ZZZ.999"

                       SET APCDERR="ZZZ.999 POV "

               End DoDot:1

 +7        SET X=0

           SET C=0

           FOR 

               SET X=$ORDER(^AUPNVPRV("AD",APCDV,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +8                IF $PIECE(^AUPNVPRV(X,0),U,4)="P"

                       SET C=C+1

               End DoDot:1

 +9        IF C>1

               SET APCDERR=APCDERR_"MULT PRIM PROV"

 +10       QUIT 

RBLK(V,L) ;left blank fill

 +1        NEW %,I

 +2        SET %=$LENGTH(V)

           SET Z=L-%

           FOR I=1:1:Z

               SET V=V_" "

 +3        QUIT V

LBLK(V,L) ;left blank fill

 +1        NEW %,I

 +2        SET %=$LENGTH(V)

           SET Z=L-%

           FOR I=1:1:Z

               SET V=" "_V

 +3        QUIT V

 +4       ;

LASTCDR(V,F) ;EP - get last chart deficiency reason

 +1       ;default to ien

           IF $GET(F)=""

               SET F="I"

 +2        IF '$DATA(^AUPNVCA("AD",V))

               QUIT ""

 +3        NEW X,A,D,L

 +4        SET X=0

           FOR 

               SET X=$ORDER(^AUPNVCA("AD",V,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +5                IF '$DATA(^AUPNVCA(X,0))

                       QUIT 

 +6                SET D=$PIECE(^AUPNVCA(X,0),U)

 +7                SET A((9999999-$PIECE(D,".")))=X

               End DoDot:1

 +8        SET L=$ORDER(A(0))

           IF L=""

               QUIT ""

 +9        SET L=A(L)

 +10       QUIT $SELECT(F="I":$PIECE(^AUPNVCA(L,0),U,6),1:$$VAL^XBDIQ1(9000010.45,L,.06))

 +11      ;

SORT(V,S) ;

 +1        NEW R

 +2        SET R=""

 +3        DO @(S_"SORT")

 +4        IF R=""

               SET R="--"

 +5        QUIT R

 +6       ;

DSORT     ;

 +1        IF 'V

               QUIT ""

 +2        IF '$DATA(^AUPNVSIT(V,0))

               QUIT ""

 +3        SET R=$PIECE(^AUPNVSIT(V,0),U)

 +4        QUIT 

 +5       ;

SSORT     ;

 +1        IF 'V

               QUIT ""

 +2        IF '$DATA(^AUPNVSIT(V,0))

               QUIT ""

 +3        SET R=$$VAL^XBDIQ1(9000010,V,.07)

 +4        QUIT 

 +5       ;

LSORT     ;

 +1        IF 'V

               QUIT ""

 +2        IF '$DATA(^AUPNVSIT(V,0))

               QUIT ""

 +3        SET R=$$VAL^XBDIQ1(9000010,V,.06)

 +4        QUIT 

 +5       ;

CSORT     ;

 +1        IF 'V

               QUIT ""

 +2        IF '$DATA(^AUPNVSIT(V,0))

               QUIT ""

 +3        SET R=$$VAL^XBDIQ1(9000010,V,.08)

 +4        QUIT 

 +5       ;

OSORT     ;

 +1        IF 'V

               QUIT ""

 +2        IF '$DATA(^AUPNVSIT(V,0))

               QUIT ""

 +3        SET R=$$VAL^XBDIQ1(9000010,V,.22)

 +4        QUIT 

 +5       ;

PSORT     ;

 +1        SET R=$$PRIMPROV^APCLV(V,"N")

 +2        QUIT 

 +3       ;

ASORT     ;

 +1        IF 'V

               QUIT ""

 +2        IF '$DATA(^AUPNVSIT(V,0))

               QUIT ""

 +3        SET R=$$VAL^XBDIQ1(9000010,V,1111)

 +4        IF R=""

               SET R="INCOMPLETE"

 +5        QUIT 

 +6       ;

RSORT     ;

 +1        SET R=$$LASTCDR(V,"E")

 +2        QUIT 

 +3       ;

NSORT     ;

 +1        SET R=$$VAL^XBDIQ1(9000010,V,.05)

 +2        QUIT 

 +3       ;

HSORT     ;

 +1        SET R=$$HRN^AUPNPAT($PIECE(^AUPNVSIT(V,0),U,5),DUZ(2))

 +2        QUIT 

 +3       ;

TSORT     ;

 +1        IF V=""

               QUIT 

 +2        IF '$DATA(^AUPNVSIT(V,0))

               QUIT ""

 +3        NEW D

 +4        SET D=$PIECE(^AUPNVSIT(V,0),U,5)

 +5        IF D=""

               QUIT 

 +6        SET R=$$HRN^AUPNPAT(D,DUZ(2))

 +7        SET R=R+10000000

           SET R=$EXTRACT(R,7,8)_$EXTRACT(R,1,6)

 +8        QUIT 

 +9       ;

EOP       ;EP - End of page.

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

               QUIT 

 +2        NEW DIR

 +3        KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT

 +4        SET DIR("A")="Press Enter to Continue"

           SET DIR(0)="E"

           DO ^DIR

 +5        QUIT 

 +6       ;----------

PRINT     ;EP - called from xbdbque

 +1        SET APCD80S="-------------------------------------------------------------------------------"

 +2        SET Y=APCDBD

           DO DD^%DT

           SET APCDBDD=Y

           SET Y=APCDED

           DO DD^%DT

           SET APCDEDD=Y

 +3        SET APCDPG=0

 +4        KILL APCDQUIT

 +5        DO COVPAGE

 +6        DO PRINT1

DONE      ;

 +1        IF $DATA(APCDQUIT)

               GOTO XIT

 +2        IF $DATA(APCDET)

               SET APCDDVTS=(86400*($PIECE(APCDET,",")-$PIECE(APCDBT,",")))+($PIECE(APCDET,",",2)-$PIECE(APCDBT,",",2))

               SET APCDDVH=$PIECE(APCDDVTS/3600,".")

               IF APCDDVH=""

                   SET APCDDVH=0

 +3        SET APCDDVTS=APCDDVTS-(APCDDVH*3600)

           SET APCDDVM=$PIECE(APCDDVTS/60,".")

           IF APCDDVM=""

               SET APCDDVM=0

           SET APCDDVTS=APCDDVTS-(APCDDVM*60)

           SET APCDDVS=APCDDVTS

           WRITE !!,"RUN TIME (H.M.S): ",APCDDVH,".",APCDDVM,".",APCDDVS