APCDCAFS ; IHS/CMI/LAB - MENTAL HLTH ROUTINE 16-AUG-1994 ;
;;2.0;IHS PCC SUITE;**2,5,8,11**;MAY 14, 2009;Build 58
;; ;
;
PROCESS ;EP
S APCDJ=$J,APCDH=$H
S ^XTMP("APCDCAFR",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"PCC UNREVIEWED 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=""
..;Q:"AOSTCR"'[$P(APCDV0,U,7) ;SERV CAT - NO I's per Dorene
..I $P(APCDV0,U,7)="I",'$D(^APCDSITE(DUZ(2),13,"B","I")) G N
..;Q:"AOSTCR"'[$P(APCDV0,U,7)
..Q:'$$SCW^APCDCAF($P(APCDV0,U,7))
N ..;
..Q:'$P(APCDV0,U,9) ;NO DEP ENTRIES
..Q:$P(APCDV0,U,11) ;DELETED
..Q:$P(APCDV0,U,3)="C" ;CONTRACT
..;Q:'$D(^AUPNVPOV("AD",APCDVIEN)) ;no pov PER CAROLYN JOHNSON, INCLUDE THEM
..;Q:'$D(^AUPNVPRV("AD",APCDVIEN)) ;no provider
..S APCDVPP=$$PRIMPROV^APCLV(APCDVIEN,"I")
..;Q:'APCDVPP ;no primary provider
..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 X=$P(APCDV0,U,7)
..Q:X="" ;no sc
..I $D(APCDSCS),'$D(APCDSCS(X)) Q ;not a sc 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 ;HOSP LOC blank and want certain HOSP LOCS
..I $D(APCDHLS),'$D(APCDHLS(APCDVHL)) Q ;not a HOSP LOC we want
..I APCDVPP="",$D(APCDPRVS) Q ;PRIM PROV blank and want certain PRIM PROVS
..I $D(APCDPRVS),'$D(APCDPRVS(APCDVPP)) Q ;not a PRIM PROV we want
..S APCDVCAS=$P($G(^AUPNVSIT(APCDVIEN,11)),U,11)
..I APCDVCAS="R" Q ;DON'T DISPLAY REVIEWED VISITS
..;I $D(APCDCASS),'$D(APCDCASS(APCDVCAS)) Q
..K APCDVCDR D GETVCDR(APCDVIEN,"APCDVCDR") ;GET ALL PENDING REASONS
..;S APCDVCDR=$$LASTCDR(APCDVIEN) ;last chart deficiency reason
..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("APCDCAFR",APCDJ,APCDH,"VISITS",$$SORT(APCDVIEN,APCDSORT),APCDVIEN)=""
..Q
.Q
Q
GETVCDR(V,R) ;EP - are there any pending deficiencies
I '$G(V) Q ""
NEW IEN,I
S IEN=0
F S IEN=$O(^AUPNCANT(V,12,IEN)) Q:IEN'=+IEN D
. S IENS=IEN_","_V
. Q:$$GET1^DIQ(9000095.12,IENS,.03)]"" ;RESOLVED
. Q:$$GET1^DIQ(9000095.12,IENS,.08)]"" ;DELETED
. S I=$$GET1^DIQ(9000095.12,IENS,.02,"I")
. Q:I=""
. S @R@(I)=""
;NOW GET ANY OLD ONES
S IEN=0 F S IEN=$O(^AUPNVCA("AD",V,IEN)) Q:IEN'=+IEN D
.S I=$P($G(^AUPNVCA(IEN,0)),U,6)
.Q:I=""
.S @R@(I)=""
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(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))
.Q:$P(^AUPNVCA(X,0),U,6)=""
.S D=$P(^AUPNVCA(X,0),U)
.S A((9999999-$P(D,".")))=X
S L=$O(A(0)) I L="" Q ""
S X=A(L)
Q $S(F="I":$P(^AUPNVCA(X,0),U,6),1:$$VAL^XBDIQ1(9000010.45,X,.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"
;Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
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("APCDCAFR",APCDJ,APCDH,"VISITS")
D EN^XBVK("APCD")
Q
PRINT1 ; Print report 2
K APCDQUIT
D HEAD
I '$D(^XTMP("APCDCAFR",APCDJ,APCDH,"VISITS")) W !!,"There are no visits that are not already reviewed." Q
S APCDS="" F S APCDS=$O(^XTMP("APCDCAFR",APCDJ,APCDH,"VISITS",APCDS)) Q:APCDS=""!($D(APCDQUIT)) D
.S APCDV="" F S APCDV=$O(^XTMP("APCDCAFR",APCDJ,APCDH,"VISITS",APCDS,APCDV)) Q:APCDV=""!($D(APCDQUIT)) D
..I $Y>(IOSL-5) D HEAD Q:$D(APCDQUIT)
..D PRN1
..D DE
..D ER
Q
ER ; CHECK FOR VARIOUS ERRORS
;no pov, no prov, .9999, multi prim prov,
Q
DE ;EP;FIND DEP ENTRIES
W !?10,"This visit has: "
S APCDVFLE=9000010 F S APCDVFLE=$O(^DIC(APCDVFLE)) Q:APCDVFLE>9000010.99!(APCDVFLE'=+APCDVFLE) D DE2
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)]"" W ?27,$P($P(^DIC(APCDVFLE,0),U),"V ",2),"'s",!
K APCDAPOV,APCDAPRV
F APCDVI=1:1 S APCDVDFN=$O(@APCDVIGR) Q:APCDVDFN="" D
.S APCDK12N=APCDVDG_APCDVDFN_",12)",APCDK12D=""
.I $D(@(APCDK12N)) S APCDK12D=@(APCDK12N)
.S APCDK16N="",APCDK16D="" I APCDVFLE=9000010.09 S APCDK16N=APCDVDG_APCDVDFN_",16)" I $D(@(APCDK16N)) S APCDK16D=@(APCDK16N)
.I $P(APCDK16D,U)]"" S APCDAPOV($P(APCDK16D,U))=""
.I $P(APCDK12D,U,13)]"" S APCDAPOV($P(APCDK12D,U,13))=""
.I $P(APCDK12D,U,2)]"" S APCDAPRV($P(^DIC(APCDVFLE,0),U)_" - "_$P($G(^VA(200,$P(APCDK12D,U,2),0)),U))=""
.I $P(APCDK12D,U,4)]"" S APCDAPRV($P(^DIC(APCDVFLE,0),U)_" - "_$P($G(^VA(200,$P(APCDK12D,U,4),0)),U))=""
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))
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) ;IHS/CMI/LAB - added acct # display
;
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/BLANK *",80)
W !,$$CTR("******************************************************************",80)
S X="VISIT Date Range: "_APCDBDD_" through "_APCDEDD W !,$$CTR(X,80)
;S X=$S(APCDLOCT="A":"ALL Locations Included",APCDLOCT="O":"Location of Encounter: "_$P(^DIC(4,APCDLOCT("ONE"),0),U),APCDLOCT="S":"LOCATIONs Included: ALL Within the "_$P(^AUTTSU(APCDLOCT("SU"),0),U)_" Service Unit",1:"")
;W !?(80-$L(X)/2),X
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 - Center X in a field Y wide.
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/BLANK *",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(APCDLOCS) 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(APCDCLNS) 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 !!,"SERVICE CATEGORIES: " D
.I '$D(APCDSCS) W "All" Q
.S Y=0,C=0 F S Y=$O(APCDSCS(Y)) Q:Y'=+Y S C=C+1 W:C>1 ";" W ?24,$$EXTSET^XBFUNC(9000010,.07,Y)
W !!,"HOSPITAL LOCATIONS: " D
.I '$D(APCDHLS) 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(APCDPRV) 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 AUDIT STATUS: " D
;.I '$D(APCDCASS) W "All" Q
;.S Y=0,C=0 F S Y=$O(APCDCASS(Y)) Q:Y'=+Y S C=C+1 W:C>1 ";" W ?24,$$EXTSET^XBFUNC(9000010.45,Y,.04)
W !!,"CHART DEFICIENCY REASONS: " D
.I '$D(APCDCDRS) 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
APCDCAFS ; IHS/CMI/LAB - MENTAL HLTH ROUTINE 16-AUG-1994 ;
+1 ;;2.0;IHS PCC SUITE;**2,5,8,11**;MAY 14, 2009;Build 58
+2 ;; ;
+3 ;
PROCESS ;EP
+1 SET APCDJ=$JOB
SET APCDH=$HOROLOG
+2 SET ^XTMP("APCDCAFR",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"PCC UNREVIEWED 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
+8 ;Q:"AOSTCR"'[$P(APCDV0,U,7) ;SERV CAT - NO I's per Dorene
+9 IF $PIECE(APCDV0,U,7)="I"
IF '$DATA(^APCDSITE(DUZ(2),13,"B","I"))
GOTO N
+10 ;Q:"AOSTCR"'[$P(APCDV0,U,7)
+11 IF '$$SCW^APCDCAF($PIECE(APCDV0,U,7))
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 ;Q:'$D(^AUPNVPOV("AD",APCDVIEN)) ;no pov PER CAROLYN JOHNSON, INCLUDE THEM
+5 ;Q:'$D(^AUPNVPRV("AD",APCDVIEN)) ;no provider
+6 SET APCDVPP=$$PRIMPROV^APCLV(APCDVIEN,"I")
+7 ;Q:'APCDVPP ;no primary provider
+8 SET APCDVLOC=$PIECE(APCDV0,U,6)
+9 ;no location of encounter
IF APCDVLOC=""
QUIT
+10 ;not a location we want
IF $DATA(APCDLOCS)
IF '$DATA(APCDLOCS(APCDVLOC))
QUIT
+11 SET X=$PIECE(APCDV0,U,7)
+12 ;no sc
IF X=""
QUIT
+13 ;not a sc we want
IF $DATA(APCDSCS)
IF '$DATA(APCDSCS(X))
QUIT
+14 SET APCDVCLN=$PIECE(APCDV0,U,8)
+15 ;clinic blank and want certain clinics
IF APCDVCLN=""
IF $DATA(APCDCLNS)
QUIT
+16 ;not a CLINIC we want
IF $DATA(APCDCLNS)
IF '$DATA(APCDCLNS(APCDVCLN))
QUIT
+17 SET APCDVHL=$PIECE(APCDV0,U,22)
+18 ;HOSP LOC blank and want certain HOSP LOCS
IF APCDVHL=""
IF $DATA(APCDHLS)
QUIT
+19 ;not a HOSP LOC we want
IF $DATA(APCDHLS)
IF '$DATA(APCDHLS(APCDVHL))
QUIT
+20 ;PRIM PROV blank and want certain PRIM PROVS
IF APCDVPP=""
IF $DATA(APCDPRVS)
QUIT
+21 ;not a PRIM PROV we want
IF $DATA(APCDPRVS)
IF '$DATA(APCDPRVS(APCDVPP))
QUIT
+22 SET APCDVCAS=$PIECE($GET(^AUPNVSIT(APCDVIEN,11)),U,11)
+23 ;DON'T DISPLAY REVIEWED VISITS
IF APCDVCAS="R"
QUIT
+24 ;I $D(APCDCASS),'$D(APCDCASS(APCDVCAS)) Q
+25 ;GET ALL PENDING REASONS
KILL APCDVCDR
DO GETVCDR(APCDVIEN,"APCDVCDR")
+26 ;S APCDVCDR=$$LASTCDR(APCDVIEN) ;last chart deficiency reason
+27 ;
IF '$DATA(APCDVCDR)
IF $DATA(APCDCDRS)
QUIT
+28 SET G=0
IF $DATA(APCDCDRS)
Begin DoDot:3
+29 SET X=0
FOR
SET X=$ORDER(APCDVCDR(X))
IF X'=+X
QUIT
IF $DATA(APCDCDRS(X))
SET G=1
End DoDot:3
+30 IF $DATA(APCDCDRS)
IF 'G
QUIT
+31 SET ^XTMP("APCDCAFR",APCDJ,APCDH,"VISITS",$$SORT(APCDVIEN,APCDSORT),APCDVIEN)=""
+32 QUIT
End DoDot:2
+33 QUIT
End DoDot:1
+34 QUIT
GETVCDR(V,R) ;EP - are there any pending deficiencies
+1 IF '$GET(V)
QUIT ""
+2 NEW IEN,I
+3 SET IEN=0
+4 FOR
SET IEN=$ORDER(^AUPNCANT(V,12,IEN))
IF IEN'=+IEN
QUIT
Begin DoDot:1
+5 SET IENS=IEN_","_V
+6 ;RESOLVED
IF $$GET1^DIQ(9000095.12,IENS,.03)]""
QUIT
+7 ;DELETED
IF $$GET1^DIQ(9000095.12,IENS,.08)]""
QUIT
+8 SET I=$$GET1^DIQ(9000095.12,IENS,.02,"I")
+9 IF I=""
QUIT
+10 SET @R@(I)=""
End DoDot:1
+11 ;NOW GET ANY OLD ONES
+12 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNVCA("AD",V,IEN))
IF IEN'=+IEN
QUIT
Begin DoDot:1
+13 SET I=$PIECE($GET(^AUPNVCA(IEN,0)),U,6)
+14 IF I=""
QUIT
+15 SET @R@(I)=""
End DoDot:1
+16 QUIT
+17 ;
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 ;I '$D(^AUPNVCA(V)) Q ""
+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 IF $PIECE(^AUPNVCA(X,0),U,6)=""
QUIT
+7 SET D=$PIECE(^AUPNVCA(X,0),U)
+8 SET A((9999999-$PIECE(D,".")))=X
End DoDot:1
+9 SET L=$ORDER(A(0))
IF L=""
QUIT ""
+10 SET X=A(L)
+11 QUIT $SELECT(F="I":$PIECE(^AUPNVCA(X,0),U,6),1:$$VAL^XBDIQ1(9000010.45,X,.06))
+12 ;
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 ;Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
+3 NEW DIR
+4 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+5 SET DIR("A")="Press Enter to Continue"
SET DIR(0)="E"
DO ^DIR
+6 QUIT
+7 ;----------
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
+4 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
SET DIR(0)="E"
DO ^DIR
KILL DIR
+5 IF $DATA(IOF)
WRITE @IOF
XIT ; Clean up and exit
+1 KILL ^XTMP("APCDCAFR",APCDJ,APCDH,"VISITS")
+2 DO EN^XBVK("APCD")
+3 QUIT
PRINT1 ; Print report 2
+1 KILL APCDQUIT
+2 DO HEAD
+3 IF '$DATA(^XTMP("APCDCAFR",APCDJ,APCDH,"VISITS"))
WRITE !!,"There are no visits that are not already reviewed."
QUIT
+4 SET APCDS=""
FOR
SET APCDS=$ORDER(^XTMP("APCDCAFR",APCDJ,APCDH,"VISITS",APCDS))
IF APCDS=""!($DATA(APCDQUIT))
QUIT
Begin DoDot:1
+5 SET APCDV=""
FOR
SET APCDV=$ORDER(^XTMP("APCDCAFR",APCDJ,APCDH,"VISITS",APCDS,APCDV))
IF APCDV=""!($DATA(APCDQUIT))
QUIT
Begin DoDot:2
+6 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(APCDQUIT)
QUIT
+7 DO PRN1
+8 DO DE
+9 DO ER
End DoDot:2
End DoDot:1
+10 QUIT
ER ; CHECK FOR VARIOUS ERRORS
+1 ;no pov, no prov, .9999, multi prim prov,
+2 QUIT
DE ;EP;FIND DEP ENTRIES
+1 WRITE !?10,"This visit has: "
+2 SET APCDVFLE=9000010
FOR
SET APCDVFLE=$ORDER(^DIC(APCDVFLE))
IF APCDVFLE>9000010.99!(APCDVFLE'=+APCDVFLE)
QUIT
DO DE2
+3 QUIT
+4 ;
DE2 ;
+1 ;DON'T DISPLAY CHART AUDIT V FILE
IF APCDVFLE=9000010.45
QUIT
+2 SET APCDVDG=^DIC(APCDVFLE,0,"GL")
SET APCDVIGR=APCDVDG_"""AD"",APCDV,APCDVDFN)"
+3 SET APCDVDFN=""
IF $ORDER(@APCDVIGR)]""
WRITE ?27,$PIECE($PIECE(^DIC(APCDVFLE,0),U),"V ",2),"'s",!
+4 KILL APCDAPOV,APCDAPRV
+5 FOR APCDVI=1:1
SET APCDVDFN=$ORDER(@APCDVIGR)
IF APCDVDFN=""
QUIT
Begin DoDot:1
+6 SET APCDK12N=APCDVDG_APCDVDFN_",12)"
SET APCDK12D=""
+7 IF $DATA(@(APCDK12N))
SET APCDK12D=@(APCDK12N)
+8 SET APCDK16N=""
SET APCDK16D=""
IF APCDVFLE=9000010.09
SET APCDK16N=APCDVDG_APCDVDFN_",16)"
IF $DATA(@(APCDK16N))
SET APCDK16D=@(APCDK16N)
+9 IF $PIECE(APCDK16D,U)]""
SET APCDAPOV($PIECE(APCDK16D,U))=""
+10 IF $PIECE(APCDK12D,U,13)]""
SET APCDAPOV($PIECE(APCDK12D,U,13))=""
+11 IF $PIECE(APCDK12D,U,2)]""
SET APCDAPRV($PIECE(^DIC(APCDVFLE,0),U)_" - "_$PIECE($GET(^VA(200,$PIECE(APCDK12D,U,2),0)),U))=""
+12 IF $PIECE(APCDK12D,U,4)]""
SET APCDAPRV($PIECE(^DIC(APCDVFLE,0),U)_" - "_$PIECE($GET(^VA(200,$PIECE(APCDK12D,U,4),0)),U))=""
End DoDot:1
+13 QUIT
+14 ;
PRN1 ;EP
+1 SET APCDVR=^AUPNVSIT(APCDV,0)
IF '$PIECE(APCDVR,U,6)
SET $PIECE(APCDVR,U,6)=0
+2 SET DFN=$PIECE(APCDVR,U,5)
+3 SET APCDHRN=""
SET APCDHRN=$$HRN^AUPNPAT(DFN,$PIECE(APCDVR,U,6),2)
+4 IF APCDHRN=""
SET APCDHRN=$$HRN^AUPNPAT(DFN,DUZ(2))
+5 WRITE !,$$FMTE^XLFDT($PIECE(APCDVR,U)),?19,APCDHRN,?31,$EXTRACT($PIECE(^DPT(DFN,0),U),1,17),?50,$EXTRACT($PIECE(^DIC(4,$PIECE(APCDVR,U,6),0),U),1,10),?61,$PIECE(APCDVR,U,7)
+6 WRITE ?64,$$CLINIC^APCLV(APCDV,"C"),?67,$EXTRACT($$VAL^XBDIQ1(9000010,APCDV,.22),1,11),?78,$PIECE(APCDVR,U,9)
+7 IF $$PRIMPROV^APCLV(APCDV,"N")]""
WRITE !," PRIMARY PROVIDER: ",$$PRIMPROV^APCLV(APCDV,"N")
+8 ;IHS/CMI/LAB - added acct # display
IF $PIECE($GET(^AUPNVSIT(APCDV,12)),U,11)]""
WRITE !," Ext Acct #: ",$PIECE($GET(^AUPNVSIT(APCDV,12)),U,11)
+9 ;
+10 QUIT
PAGEHEAD ;
HEAD ;EP;HEADER
+1 IF $DATA(APCDDEM)!($DATA(APCDDEMM))
GOTO HEAD2
+2 IF 'APCDPG
GOTO HEAD1
HEAD2 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCDQUIT=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET APCDPG=APCDPG+1
+2 WRITE !,$$FMTE^XLFDT(DT),?70,"Page: ",APCDPG
+3 WRITE !?29,"PCC Data Entry Module"
+4 WRITE !,$$CTR("******************************************************************",80)
+5 WRITE !,$$CTR("* LIST OF VISITS WITH CHART AUDIT STATUS OF INCOMPLETE/BLANK *",80)
+6 WRITE !,$$CTR("******************************************************************",80)
+7 SET X="VISIT Date Range: "_APCDBDD_" through "_APCDEDD
WRITE !,$$CTR(X,80)
+8 ;S X=$S(APCDLOCT="A":"ALL Locations Included",APCDLOCT="O":"Location of Encounter: "_$P(^DIC(4,APCDLOCT("ONE"),0),U),APCDLOCT="S":"LOCATIONs Included: ALL Within the "_$P(^AUTTSU(APCDLOCT("SU"),0),U)_" Service Unit",1:"")
+9 ;W !?(80-$L(X)/2),X
+10 WRITE !!,"VISIT DATE",?19,"HRN",?31,"PATIENT NAME",?50,"LOCATION",?61,"SC",?64,"CL",?67,"HOSP LOC",?77,"DEC"
+11 WRITE !,APCD80S
+12 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
COVPAGE ;
+1 WRITE !,$$FMTE^XLFDT(DT),?70,"Page: ",APCDPG
+2 WRITE !?29,"PCC Data Entry Module"
+3 WRITE !,$$CTR("******************************************************************",80)
+4 WRITE !,$$CTR("* LIST OF VISITS WITH CHART AUDIT STATUS OF INCOMPLETE/BLANK *",80)
+5 WRITE !,$$CTR("******************************************************************",80)
+6 WRITE !!,$$CTR("VISIT LIST CRITERIA",80)
+7 WRITE !!,"VISIT DATES: ",$$FMTE^XLFDT(APCDBD)," to ",$$FMTE^XLFDT(APCDED)
+8 WRITE !,"VISIT TYPE: NOT Contract"
+9 WRITE !!,"LOCATION OF ENCOUNTER: "
Begin DoDot:1
+10 IF '$DATA(APCDLOCS)
WRITE "All"
QUIT
+11 SET Y=0
SET C=0
FOR
SET Y=$ORDER(APCDLOCS(Y))
IF Y'=+Y
QUIT
SET C=C+1
IF C>1
WRITE ";"
WRITE ?24,$EXTRACT($PIECE(^DIC(4,Y,0),U),1,15)
End DoDot:1
+12 WRITE !!,"CLINICS: "
Begin DoDot:1
+13 IF '$DATA(APCDCLNS)
WRITE "All"
QUIT
+14 SET Y=0
SET C=0
FOR
SET Y=$ORDER(APCDCLNS(Y))
IF Y'=+Y
QUIT
SET C=C+1
IF C>1
WRITE ";"
WRITE ?24,$EXTRACT($PIECE(^DIC(40.7,Y,0),U),1,15)
End DoDot:1
+15 WRITE !!,"SERVICE CATEGORIES: "
Begin DoDot:1
+16 IF '$DATA(APCDSCS)
WRITE "All"
QUIT
+17 SET Y=0
SET C=0
FOR
SET Y=$ORDER(APCDSCS(Y))
IF Y'=+Y
QUIT
SET C=C+1
IF C>1
WRITE ";"
WRITE ?24,$$EXTSET^XBFUNC(9000010,.07,Y)
End DoDot:1
+18 WRITE !!,"HOSPITAL LOCATIONS: "
Begin DoDot:1
+19 IF '$DATA(APCDHLS)
WRITE "All"
QUIT
+20 SET Y=0
SET C=0
FOR
SET Y=$ORDER(APCDHLS(Y))
IF Y'=+Y
QUIT
SET C=C+1
IF C>1
WRITE ";"
WRITE ?24,$EXTRACT($PIECE(^SC(Y,0),U),1,15)
End DoDot:1
+21 WRITE !!,"PRIMARY PROVIDER ON VISIT: "
Begin DoDot:1
+22 IF '$DATA(APCDPRV)
WRITE "All"
QUIT
+23 SET Y=0
SET C=0
FOR
SET Y=$ORDER(APCDPRVS(Y))
IF Y'=+Y
QUIT
SET C=C+1
IF C>1
WRITE ";"
WRITE ?24,$EXTRACT($PIECE(^VA(200,Y,0),U),1,15)
End DoDot:1
+24 ;W !!,"CHART AUDIT STATUS: " D
+25 ;.I '$D(APCDCASS) W "All" Q
+26 ;.S Y=0,C=0 F S Y=$O(APCDCASS(Y)) Q:Y'=+Y S C=C+1 W:C>1 ";" W ?24,$$EXTSET^XBFUNC(9000010.45,Y,.04)
+27 WRITE !!,"CHART DEFICIENCY REASONS: "
Begin DoDot:1
+28 IF '$DATA(APCDCDRS)
WRITE "All (includes visits with no chart deficiency reason entered"
QUIT
+29 SET Y=0
SET C=0
FOR
SET Y=$ORDER(APCDCDRS(Y))
IF Y'=+Y
QUIT
SET C=C+1
IF C>1
WRITE ";"
WRITE ?24,$EXTRACT($PIECE(^AUTTCDR(Y,0),U),1,15)
End DoDot:1
+30 QUIT
