APCDCAF ; IHS/CMI/LAB - MENTAL HLTH ROUTINE 16-AUG-1994 ;
;;2.0;IHS PCC SUITE;**2,7,8,11,15,20**;MAY 14, 2009;Build 25
;
;
EN ; EP -- main entry point
S VALMCC=1
NEW VALCNT
D TERM^VALM0
D CLEAR^VALM1
D EN^VALM("APCDCAF MAIN VIEW")
D CLEAR^VALM1
Q
;
HDR ;EP -- header code
S VALMHDR(1)="Visit Dates: "_$$FMTE^XLFDT(APCDBD)_" to "_$$FMTE^XLFDT(APCDED)
S X=" #",$E(X,6)="VISIT DATE",$E(X,21)="PATIENT NAME",$E(X,35)="HRN",$E(X,42)="FAC",$E(X,47)="HOSP LOC",$E(X,56)="S",$E(X,58)="CL",$E(X,61)="INS",$E(X,66)="PRIM PROV",$E(X,76)="STATUS ERROR"
S VALMHDR(3)=X
S VALMHDR(2)="* an asterisk beside the visit number indicates the visit has an error"
Q
;
INIT ;EP -- init variables/list array
S VALMSG="Q - Quit/?? for more actions/+ next/- previous"
D GATHER
D RECDISP
S VALMCNT=APCDRCNT
Q
;
HELP ;EP -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K APCDRCNT,^TMP($J),^TMP("APCDCAF",$J)
Q
;
EXPND ; -- expand code
Q
;
SCW(C) ;EP
I C="" Q 0
I C="E" Q 0
I C="D" Q 0 ;NOT USED BY IHS
I C="X" Q 0 ;NOT USED BY IHS
I $D(^APCDSITE(DUZ(2),13,"B",C)) Q 0
Q 1
;
GATHER ;
K ^TMP("APCDCAF",$J),^TMP($J)
I $G(APCDCAFP) D GATHERP Q
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:$P(APCDV0,U,5)=""
..Q:'$D(^AUPNPAT($P(APCDV0,U,5),0))
..Q:'$D(^DPT($P(APCDV0,U,5),0))
..Q:$$DEMO^APCLUTL($P(APCDV0,U,5),APCDDEMO)
..Q:$P(APCDV0,U,7)=""
..Q:'$$SCW($P(APCDV0,U,7))
..Q:'$P(APCDV0,U,9) ;NO DEP ENTRIES
..Q:$P(APCDV0,U,11) ;DELETED
..Q:$P(APCDV0,U,3)="C" ;CONTRACT
..I $P(^APCDSITE(DUZ(2),0),U,28)=0,APCDPRVT'="X" 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 APCDVCLN=$P(APCDV0,U,8)
..I APCDCLNT="X",APCDVCLN]"" Q
..I APCDVCLN="",$D(APCDCLNS) Q
..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 APCDPRVT="X",APCDVPP Q
..I APCDPRVT'="C",$D(APCDPRVS),'$D(APCDPRVS(APCDVPP)) Q ;not a PRIM PROV we want
..I APCDPRVT'="C" G CAS
..S X=0,G=0,H=0 F S X=$O(^AUPNVPRV("AD",APCDVIEN,X)) Q:X'=+X I $P(^AUPNVPRV(X,0),U,4)'="P" S S=$$VALI^XBDIQ1(9000010.06,X,.01) D
...I $D(APCDPRVS(S)) S H=1
..Q:'H
CAS ..S APCDVCAS=$P($G(^AUPNVSIT(APCDVIEN,11)),U,11)
..I APCDVCAS="R" Q ;DON'T DISPLAY REVIEWED VISITS
..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 ^TMP($J,"APCDCAF",$$SORT(APCDVIEN,APCDSORT),APCDVIEN)=""
..Q
.Q
Q
;
GATHERP ; gather up visits for 1 patient
S APCDODAT=9999999-APCDED,APCDSTOP=9999999-APCDBD
S (APCDRCNT,APCDVIEN)=0 F S APCDODAT=$O(^AUPNVSIT("AA",APCDCAFP,APCDODAT)) Q:APCDODAT=""!($P(APCDODAT,".")>APCDSTOP) D
.S APCDVIEN=0 F S APCDVIEN=$O(^AUPNVSIT("AA",APCDCAFP,APCDODAT,APCDVIEN)) Q:APCDVIEN'=+APCDVIEN D
..S APCDV0=$G(^AUPNVSIT(APCDVIEN,0))
..Q:APCDV0=""
..Q:'$$SCW($P(APCDV0,U,7))
..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
..;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
..S APCDVCAS=$P($G(^AUPNVSIT(APCDVIEN,11)),U,11)
..I APCDVCAS="R" Q ;DON'T DISPLAY REVIEWED VISITS
..S ^TMP($J,"APCDCAF",$$SORT(APCDVIEN,APCDSORT),APCDVIEN)=""
..Q
.Q
Q
RECDISP ;
S APCDSV="" F S APCDSV=$O(^TMP($J,"APCDCAF",APCDSV)) Q:APCDSV="" D
.S APCDV=0 F S APCDV=$O(^TMP($J,"APCDCAF",APCDSV,APCDV)) Q:APCDV'=+APCDV D
..S APCDRCNT=APCDRCNT+1
..S APCDX="",DFN=$P(^AUPNVSIT(APCDV,0),U,5) D REC
..S ^TMP("APCDCAF",$J,APCDRCNT,0)=APCDX
..S ^TMP("APCDCAF",$J,"IDX",APCDRCNT,APCDRCNT)=APCDV
K APCDV,APCDX,APCDSV
Q
;
ONEDATE ;
W !!,"This item is used to display all visits for a patient on the",!,"same date as the visit you select from the list."
K DIR
S DIR(0)="NO^1:"_APCDRCNT,DIR("A")="Which Visit"
D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y="" W !,"No VISIT selected." D EOP G ONEDATEX
I $D(DIRUT) W !,"No VISIT selected." D EOP G ONEDATEX
S APCDVSIT=^TMP("APCDCAF",$J,"IDX",Y,Y)
;RELINKER?
D EP^APCDKDE
S APCDCAFD=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
S APCDCAFO=1
S APCDDFN=$P(^AUPNVSIT(APCDVSIT,0),U,5)
D EN^APCDCAF2
;
ONEDATEX ;
K DIR,DIRUT,DUOUT,Y,APCDVSIT,APCDCAF,APCDCAFV,APCDCAFD,APCDCAFO,APCDDFN
D KILL^AUPNPAT
D BACK
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
;
REC ;
S APCDERR=$$ERRORCHK(APCDV)
S APCDX=""
S APCDX=APCDRCNT_")"_$S(APCDERR]"":"*",1:"")
S $E(APCDX,6)=$$DATE($P(^AUPNVSIT(APCDV,0),U))
S $E(APCDX,21)=$E($P(^DPT(DFN,0),U),1,13)
S $E(APCDX,35)=$$LBLK($$HRN^AUPNPAT(DFN,DUZ(2)),6)
S L=$P(^AUPNVSIT(APCDV,0),U,6)
S L=$P($G(^AUTTLOC(L,0)),U,7)
S $E(APCDX,42)=L
S $E(APCDX,47)=$E($$VAL^XBDIQ1(9000010,APCDV,.22),1,8)
S $E(APCDX,56)=$P(^AUPNVSIT(APCDV,0),U,7)
S $E(APCDX,58)=$$CLINIC^APCLV(APCDV,"C")
S $E(APCDX,61)=$$MCP(APCDV)
S $E(APCDX,66)=$E($$PRIMPROV^APCLV(APCDV,"N"),1,9)
S L=$P($G(^AUPNVSIT(APCDV,11)),U,11)
S $E(APCDX,76)=L
S $E(APCDX,78)=APCDERR
Q
;
ERRORCHK(V) ;EP
NEW E,X,C
S E=""
I $P(^AUPNVSIT(V,0),U,7)="E" Q ""
I $P(^AUPNVSIT(V,0),U,7)'="I",'$D(^AUPNVPOV("AD",V)) S E="NO POV"
S X=0 F S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X D
.I $$VAL^XBDIQ1(9000010.07,X,.01)=".9999" S:E]"" E=E_"," S E=".9999 POV" Q
.I $$VAL^XBDIQ1(9000010.07,X,.01)="ZZZ.999" S:E]"" E=E_"," S E="ZZZ.999 POV"
S X=0,C=0 F S X=$O(^AUPNVPRV("AD",V,X)) Q:X'=+X D
.I $P(^AUPNVPRV(X,0),U,4)="P" S C=C+1
I C>1 S:E]"" E=E_"," S E=E_"MULT PRIM PROV"
I $$FINDPEND^APCDCAF6(V) S:E]"" E=E_"," S E=E_"CHART DEFICIENCIES"
Q E
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" ;
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))
.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,5),1:$$VAL^XBDIQ1(9000010.45,X,.05))
;
MCP(V) ;
NEW R S R=""
I V="" Q ""
I '$D(^AUPNVSIT(V,0)) Q ""
NEW D
S D=$P(^AUPNVSIT(V,0),U,5)
I D="" Q ""
I $$MCR^AUPNPAT(D,$P($P(^AUPNVSIT(V,0),U),".")) S R="M"
I $$MCD^AUPNPAT(D,$P($P(^AUPNVSIT(V,0),U),".")) S:R]"" R=R_"/" S R=R_"C"
I $$PI^AUPNPAT(D,$P($P(^AUPNVSIT(V,0),U),".")) S:R]"" R=R_"/" S R=R_"P"
Q R
SORT(V,S) ;
NEW R
S R=""
D @(S_"SORT")
I R="" S R="ZZZZZZZZ"
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
;
ISORT ;
I V="" Q
I '$D(^AUPNVSIT(V,0)) Q
NEW D
S D=$P(^AUPNVSIT(V,0),U,5)
I $$MCR^AUPNPAT(D,$P($P(^AUPNVSIT(V,0),U),".")) S R="M"
I $$MCD^AUPNPAT(D,$P($P(^AUPNVSIT(V,0),U),".")) S:R]"" R=R_"/" S R=R_"C"
I $$PI^AUPNPAT(D,$P($P(^AUPNVSIT(V,0),U),".")) S:R]"" R=R_"/" S R=R_"P"
Q
BACK ;EP go back
D TERM^VALM0
S VALMBCK="R"
D INIT
D HDR
K DIR
K X,Y,Z,I
Q
;
NOTEDISP ;
K DIR
I $T(BROWS1^TIURA2)="" W !!,"TIU not installed" D EOP G NOTEX
S DIR(0)="NO^1:"_APCDRCNT,DIR("A")="Display Note for which Visit"
D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y="" W !,"No VISIT selected." D EOP G NOTEX
I $D(DIRUT) W !,"No VISIT selected." D EOP G NOTEX
S APCDVSIT=^TMP("APCDCAF",$J,"IDX",Y,Y)
D FULL^VALM1
I '$D(^AUPNVNOT("AD",APCDVSIT)) W !!,"That visit does not have any notes to view" D EOP G NOTEX
S (C,X)=0 F S X=$O(^AUPNVNOT("AD",APCDVSIT,X)) Q:X'=+X S C=C+1
I C=1 S APCDVNOT=$O(^AUPNVNOT("AD",APCDVSIT,0)) D NOTE1 G NOTEX
;
MNOTE ;
W !!,"There are more than one note associated with this visit.",!,"Please choose which note to display.",!
K APCDN
S (X,C)=0 F S X=$O(^AUPNVNOT("AD",APCDVSIT,X)) Q:X'=+X S C=C+1 D
.W !?3,C,") ",$$VAL^XBDIQ1(9000010.28,X,.01),?40,$$VAL^XBDIQ1(9000010.28,X,1202)
.S APCDN(C)=X
.Q
K DIR
S DIR(0)="NO^1:"_C,DIR("A")="Display which Note"
D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y="" G NOTEX
I $D(DIRUT) G NOTEX
S APCDVNOT=APCDN(Y)
NOTE1 ;
S APCDTIU=$P(^AUPNVNOT(APCDVNOT,0),U)
D BROWS1^TIURA2("TIU BROWSE FOR READ ONLY",APCDTIU)
;
NOTEX ;
K DIR,DIRUT,DUOUT,Y,APCDVSIT,APCDVNOT,X,APCDTIU
D KILL^AUPNPAT
D BACK
Q
;
CASHX ;EP
D FULL^VALM1
K DIR
S DIR(0)="NO^1:"_APCDRCNT,DIR("A")="Display Chart Audit History for which Visit"
D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y="" W !,"No VISIT selected." D EOP G CASHXX
I $D(DIRUT) W !,"No VISIT selected." D EOP G CASHXX
S APCDVSIT=^TMP("APCDCAF",$J,"IDX",Y,Y)
D VIEWR^XBLM("DCAH^APCDCAF")
;
CASHXX ;
K DIR,DIRUT,DUOUT,Y,APCDVSIT
D BACK
Q
DCAH ;
;
W !!,"Chart Audit History for VISIT:"
W !?1,"Visit Date: ",$$VAL^XBDIQ1(9000010,APCDVSIT,.01)," Patient Name: ",$$VAL^XBDIQ1(9000010,APCDVSIT,.05)
W !?1,"Hospital Location: ",$$VAL^XBDIQ1(9000010,APCDVSIT,.22)," Primary Provider: ",$$PRIMPROV^APCLV(APCDVSIT,"N")
W !!,"DATE OF AUDIT",?24,"STATUS",?40,"USER WHO AUDITED"
S APCDX=0 F S APCDX=$O(^AUPNVCA("AD",APCDVSIT,APCDX)) Q:APCDX'=+APCDX D
.W !,$$GET1^DIQ(9000010.45,APCDX,.01),?24,$$GET1^DIQ(9000010.45,APCDX,.04),?40,$$GET1^DIQ(9000010.45,APCDX,.05)
W !!,"DEFICIENCY HISTORY"
W !,"=================="
S APCDX=0 F S APCDX=$O(^AUPNVCA("AD",APCDVSIT,APCDX)) Q:APCDX'=+APCDX D
.Q:$P(^AUPNVCA(APCDX,0),U,6)=""
.W !,$$GET1^DIQ(9000010.45,APCDX,.06),?31,$$DATE^APCDCAFA($P($P(^AUPNVSIT(APCDVSIT,0),U),".")),?42,$E($$GET1^DIQ(9000010.45,APCDX,.05),1,18)
S DA=APCDVSIT,DIC="^AUPNCANT(" D EN^DIQ
Q
RESORT ;
D FULL^VALM1
W !!,"Resorting Visit List",!
S DIR(0)="S^N:Patient Name;H:HRN;D:Date of Visit;T:Terminal Digit of HRN;S:Service Category;L:Location of Encounter;C:Clinic;O:Hospital Location;P:Primary Provider"
S DIR(0)=DIR(0)_";A:Chart Audit Status;I:Has Medicare/Medicaid or PI"
S DIR("A")="How would you like the list of visits sorted",DIR("B")="D" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G RESORTX
S APCDSORT=Y
;
RESORTX ;
D BACK
Q
;
HS ;
D FULL^VALM1
I $G(APCDCAFP) S (DFN,APCHSPAT,APCDPAT,Y)=APCDCAFP G HS1
K DIR
S DIR(0)="NO^1:"_APCDRCNT,DIR("A")="Select Visit for Patient's Health summary"
D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y="" W !,"No VISIT selected." D EOP G HSX
I $D(DIRUT) W !,"No VISIT selected." D EOP G HSX
S APCDVSIT=^TMP("APCDCAF",$J,"IDX",Y,Y)
S (Y,APCDPAT,DFN,APCHSPAT)=$P(^AUPNVSIT(APCDVSIT,0),U,5)
HS1 ;
S X="" I DUZ(2),$D(^APCCCTRL(DUZ(2),0))#2 S X=$P(^(0),U,3) I X,$D(^APCHSCTL(X,0)) S X=$P(^APCHSCTL(X,0),U)
I $D(^DISV(DUZ,"^APCHSCTL(")) S Y=^("^APCHSCTL(") I $D(^APCHSCTL(Y,0)) S X=$P(^(0),U,1)
S:X="" X="ADULT REGULAR"
K DIC,DR,DD S DIC("B")=X,DIC="^APCHSCTL(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DD,D0,D1,DQ
I Y=-1 D EOP G HSX
S APCHSTYP=+Y,APCHSPAT=DFN
S APCDHDR="PCC Health Summary for "_$P(^DPT(APCHSPAT,0),U)
D VIEWR^XBLM("EN^APCHS",APCDHDR)
HSX ;
K APCDVSIT,APCDPAT,X,Y,AUPNVSIT,AUPNDAYS,DFN,APCDHDR,APCDPLPT
D EN^XBVK("APCH")
D KILL^AUPNPAT
D BACK
Q
;
EOP ;EP
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
;
BH ;EP
K DIR
I '$D(^XUSEC("AMHZ CODING REVIEW",DUZ)) W !!,"You do not have the security access to see Behavioral Health Notes.",!,"Please see your supervisor for access. The security key needed is AMHZ CODING REVIEW.",! D PAUSE^APCDALV1,BHX Q
S DIR(0)="NO^1:"_APCDRCNT,DIR("A")="Display Behavioral Health Note for which Visit"
D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y="" W !,"No VISIT selected." D EOP G BHX
I $D(DIRUT) W !,"No VISIT selected." D EOP G BHX
S APCDVSIT=^TMP("APCDCAF",$J,"IDX",Y,Y)
D FULL^VALM1
I '$D(^AMHREC("AVISIT",APCDVSIT)) D G BHX
.W !!,"There is no visit in the Behavioral Health module that is associated"
.W !,"with this visit. Use the N - Note Display action to display notes for "
.W !,"non-BH visits."
.D EOP
S APCDVBH=$O(^AMHREC("AVISIT",APCDVSIT,0))
I '$D(^AUPNVNOT("AD",APCDVSIT)) G BHSOAP
S (C,X)=0 F S X=$O(^AUPNVNOT("AD",APCDVSIT,X)) Q:X'=+X S C=C+1
I C=1 S APCDVNOT=$O(^AUPNVNOT("AD",APCDVSIT,0)) D BH1 G BHSOAP
;
BHM ;
W !!,"There are more than one note associated with this visit.",!,"Please choose which note to display.",!
K APCDN
S (X,C)=0 F S X=$O(^AUPNVNOT("AD",APCDVSIT,X)) Q:X'=+X S C=C+1 D
.W !?3,C,") ",$$VAL^XBDIQ1(9000010.28,X,.01),?40,$$VAL^XBDIQ1(9000010.28,X,1202)
.S APCDN(C)=X
.Q
K DIR
S DIR(0)="NO^1:"_C,DIR("A")="Display which Note"
D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y="" G BHSOAP
I $D(DIRUT) G BHSOAP
S APCDVNOT=APCDN(Y)
BH1 ;
S APCDTIU=$P(^AUPNVNOT(APCDVNOT,0),U)
D BROWS1^TIURA2("TIU BROWSE FOR READ ONLY",APCDTIU)
;
BHSOAP ;look for SOAP note
I $O(^AMHREC(APCDVBH,31,0)) D
.W !!,"The SOAP note from the Behavioral Health module will now be displayed."
.W !! S DIR(0)="Y",DIR("A")="Do you want to continue",DIR("B")="Y" KILL DA D ^DIR KILL DIR
.I $D(DIRUT) Q
.I 'Y Q
.D ARRAY^XBLM("^AMHREC("_APCDVBH_",31,","Behavior Health SOAP Note for visit: "_$$VAL^XBDIQ1(9002011,APCDVBH,.01))
.Q
BHX ;
K DIR,DIRUT,DUOUT,Y,APCDVSIT,APCDVNOT,X,APCDTIU
D KILL^AUPNPAT
D BACK
Q
APCDCAF ; IHS/CMI/LAB - MENTAL HLTH ROUTINE 16-AUG-1994 ;
+1 ;;2.0;IHS PCC SUITE;**2,7,8,11,15,20**;MAY 14, 2009;Build 25
+2 ;
+3 ;
EN ; EP -- main entry point
+1 SET VALMCC=1
+2 NEW VALCNT
+3 DO TERM^VALM0
+4 DO CLEAR^VALM1
+5 DO EN^VALM("APCDCAF MAIN VIEW")
+6 DO CLEAR^VALM1
+7 QUIT
+8 ;
HDR ;EP -- header code
+1 SET VALMHDR(1)="Visit Dates: "_$$FMTE^XLFDT(APCDBD)_" to "_$$FMTE^XLFDT(APCDED)
+2 SET X=" #"
SET $EXTRACT(X,6)="VISIT DATE"
SET $EXTRACT(X,21)="PATIENT NAME"
SET $EXTRACT(X,35)="HRN"
SET $EXTRACT(X,42)="FAC"
SET $EXTRACT(X,47)="HOSP LOC"
SET $EXTRACT(X,56)="S"
SET $EXTRACT(X,58)="CL"
SET $EXTRACT(X,61)="INS"
SET $EXTRACT(X,66)="PRIM PROV"
SET $EXTRACT(X,76)="STATUS ERROR"
+3 SET VALMHDR(3)=X
+4 SET VALMHDR(2)="* an asterisk beside the visit number indicates the visit has an error"
+5 QUIT
+6 ;
INIT ;EP -- init variables/list array
+1 SET VALMSG="Q - Quit/?? for more actions/+ next/- previous"
+2 DO GATHER
+3 DO RECDISP
+4 SET VALMCNT=APCDRCNT
+5 QUIT
+6 ;
HELP ;EP -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL APCDRCNT,^TMP($JOB),^TMP("APCDCAF",$JOB)
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
SCW(C) ;EP
+1 IF C=""
QUIT 0
+2 IF C="E"
QUIT 0
+3 ;NOT USED BY IHS
IF C="D"
QUIT 0
+4 ;NOT USED BY IHS
IF C="X"
QUIT 0
+5 IF $DATA(^APCDSITE(DUZ(2),13,"B",C))
QUIT 0
+6 QUIT 1
+7 ;
GATHER ;
+1 KILL ^TMP("APCDCAF",$JOB),^TMP($JOB)
+2 IF $GET(APCDCAFP)
DO GATHERP
QUIT
+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 IF $PIECE(APCDV0,U,5)=""
QUIT
+9 IF '$DATA(^AUPNPAT($PIECE(APCDV0,U,5),0))
QUIT
+10 IF '$DATA(^DPT($PIECE(APCDV0,U,5),0))
QUIT
+11 IF $$DEMO^APCLUTL($PIECE(APCDV0,U,5),APCDDEMO)
QUIT
+12 IF $PIECE(APCDV0,U,7)=""
QUIT
+13 IF '$$SCW($PIECE(APCDV0,U,7))
QUIT
+14 ;NO DEP ENTRIES
IF '$PIECE(APCDV0,U,9)
QUIT
+15 ;DELETED
IF $PIECE(APCDV0,U,11)
QUIT
+16 ;CONTRACT
IF $PIECE(APCDV0,U,3)="C"
QUIT
+17 ;no provider
IF $PIECE(^APCDSITE(DUZ(2),0),U,28)=0
IF APCDPRVT'="X"
IF '$DATA(^AUPNVPRV("AD",APCDVIEN))
QUIT
+18 SET APCDVPP=$$PRIMPROV^APCLV(APCDVIEN,"I")
+19 ;Q:'APCDVPP ;no primary provider
+20 SET APCDVLOC=$PIECE(APCDV0,U,6)
+21 ;no location of encounter
IF APCDVLOC=""
QUIT
+22 ;not a location we want
IF $DATA(APCDLOCS)
IF '$DATA(APCDLOCS(APCDVLOC))
QUIT
+23 SET APCDVCLN=$PIECE(APCDV0,U,8)
+24 IF APCDCLNT="X"
IF APCDVCLN]""
QUIT
+25 IF APCDVCLN=""
IF $DATA(APCDCLNS)
QUIT
+26 ;not a CLINIC we want
IF $DATA(APCDCLNS)
IF '$DATA(APCDCLNS(APCDVCLN))
QUIT
+27 SET APCDVHL=$PIECE(APCDV0,U,22)
+28 IF APCDVHL=""
IF $DATA(APCDHLS)
QUIT
+29 ;not a HOSP LOC we want
IF $DATA(APCDHLS)
IF '$DATA(APCDHLS(APCDVHL))
QUIT
+30 IF APCDVPP=""
IF $DATA(APCDPRVS)
QUIT
+31 IF APCDPRVT="X"
IF APCDVPP
QUIT
+32 ;not a PRIM PROV we want
IF APCDPRVT'="C"
IF $DATA(APCDPRVS)
IF '$DATA(APCDPRVS(APCDVPP))
QUIT
+33 IF APCDPRVT'="C"
GOTO CAS
+34 SET X=0
SET G=0
SET H=0
FOR
SET X=$ORDER(^AUPNVPRV("AD",APCDVIEN,X))
IF X'=+X
QUIT
IF $PIECE(^AUPNVPRV(X,0),U,4)'="P"
SET S=$$VALI^XBDIQ1(9000010.06,X,.01)
Begin DoDot:3
+35 IF $DATA(APCDPRVS(S))
SET H=1
End DoDot:3
+36 IF 'H
QUIT
CAS SET APCDVCAS=$PIECE($GET(^AUPNVSIT(APCDVIEN,11)),U,11)
+1 ;DON'T DISPLAY REVIEWED VISITS
IF APCDVCAS="R"
QUIT
+2 ;GET ALL PENDING REASONS
KILL APCDVCDR
DO GETVCDR^APCDCAFS(APCDVIEN,"APCDVCDR")
+3 ;
IF '$DATA(APCDVCDR)
IF $DATA(APCDCDRS)
QUIT
+4 SET G=0
IF $DATA(APCDCDRS)
Begin DoDot:3
+5 SET X=0
FOR
SET X=$ORDER(APCDVCDR(X))
IF X'=+X
QUIT
IF $DATA(APCDCDRS(X))
SET G=1
End DoDot:3
+6 IF $DATA(APCDCDRS)
IF 'G
QUIT
+7 SET ^TMP($JOB,"APCDCAF",$$SORT(APCDVIEN,APCDSORT),APCDVIEN)=""
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
GATHERP ; gather up visits for 1 patient
+1 SET APCDODAT=9999999-APCDED
SET APCDSTOP=9999999-APCDBD
+2 SET (APCDRCNT,APCDVIEN)=0
FOR
SET APCDODAT=$ORDER(^AUPNVSIT("AA",APCDCAFP,APCDODAT))
IF APCDODAT=""!($PIECE(APCDODAT,".")>APCDSTOP)
QUIT
Begin DoDot:1
+3 SET APCDVIEN=0
FOR
SET APCDVIEN=$ORDER(^AUPNVSIT("AA",APCDCAFP,APCDODAT,APCDVIEN))
IF APCDVIEN'=+APCDVIEN
QUIT
Begin DoDot:2
+4 SET APCDV0=$GET(^AUPNVSIT(APCDVIEN,0))
+5 IF APCDV0=""
QUIT
+6 IF '$$SCW($PIECE(APCDV0,U,7))
QUIT
+7 ;NO DEP ENTRIES
IF '$PIECE(APCDV0,U,9)
QUIT
+8 ;DELETED
IF $PIECE(APCDV0,U,11)
QUIT
+9 ;CONTRACT
IF $PIECE(APCDV0,U,3)="C"
QUIT
+10 ;Q:'$D(^AUPNVPOV("AD",APCDVIEN)) ;no pov
+11 ;Q:'$D(^AUPNVPRV("AD",APCDVIEN)) ;no provider
+12 SET APCDVPP=$$PRIMPROV^APCLV(APCDVIEN,"I")
+13 ;Q:'APCDVPP ;no primary provider
+14 SET APCDVLOC=$PIECE(APCDV0,U,6)
+15 ;no location of encounter
IF APCDVLOC=""
QUIT
+16 SET APCDVCAS=$PIECE($GET(^AUPNVSIT(APCDVIEN,11)),U,11)
+17 ;DON'T DISPLAY REVIEWED VISITS
IF APCDVCAS="R"
QUIT
+18 SET ^TMP($JOB,"APCDCAF",$$SORT(APCDVIEN,APCDSORT),APCDVIEN)=""
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 QUIT
RECDISP ;
+1 SET APCDSV=""
FOR
SET APCDSV=$ORDER(^TMP($JOB,"APCDCAF",APCDSV))
IF APCDSV=""
QUIT
Begin DoDot:1
+2 SET APCDV=0
FOR
SET APCDV=$ORDER(^TMP($JOB,"APCDCAF",APCDSV,APCDV))
IF APCDV'=+APCDV
QUIT
Begin DoDot:2
+3 SET APCDRCNT=APCDRCNT+1
+4 SET APCDX=""
SET DFN=$PIECE(^AUPNVSIT(APCDV,0),U,5)
DO REC
+5 SET ^TMP("APCDCAF",$JOB,APCDRCNT,0)=APCDX
+6 SET ^TMP("APCDCAF",$JOB,"IDX",APCDRCNT,APCDRCNT)=APCDV
End DoDot:2
End DoDot:1
+7 KILL APCDV,APCDX,APCDSV
+8 QUIT
+9 ;
ONEDATE ;
+1 WRITE !!,"This item is used to display all visits for a patient on the",!,"same date as the visit you select from the list."
+2 KILL DIR
+3 SET DIR(0)="NO^1:"_APCDRCNT
SET DIR("A")="Which Visit"
+4 DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+5 IF Y=""
WRITE !,"No VISIT selected."
DO EOP
GOTO ONEDATEX
+6 IF $DATA(DIRUT)
WRITE !,"No VISIT selected."
DO EOP
GOTO ONEDATEX
+7 SET APCDVSIT=^TMP("APCDCAF",$JOB,"IDX",Y,Y)
+8 ;RELINKER?
+9 DO EP^APCDKDE
+10 SET APCDCAFD=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
+11 SET APCDCAFO=1
+12 SET APCDDFN=$PIECE(^AUPNVSIT(APCDVSIT,0),U,5)
+13 DO EN^APCDCAF2
+14 ;
ONEDATEX ;
+1 KILL DIR,DIRUT,DUOUT,Y,APCDVSIT,APCDCAF,APCDCAFV,APCDCAFD,APCDCAFO,APCDDFN
+2 DO KILL^AUPNPAT
+3 DO BACK
+4 QUIT
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 ;
REC ;
+1 SET APCDERR=$$ERRORCHK(APCDV)
+2 SET APCDX=""
+3 SET APCDX=APCDRCNT_")"_$SELECT(APCDERR]"":"*",1:"")
+4 SET $EXTRACT(APCDX,6)=$$DATE($PIECE(^AUPNVSIT(APCDV,0),U))
+5 SET $EXTRACT(APCDX,21)=$EXTRACT($PIECE(^DPT(DFN,0),U),1,13)
+6 SET $EXTRACT(APCDX,35)=$$LBLK($$HRN^AUPNPAT(DFN,DUZ(2)),6)
+7 SET L=$PIECE(^AUPNVSIT(APCDV,0),U,6)
+8 SET L=$PIECE($GET(^AUTTLOC(L,0)),U,7)
+9 SET $EXTRACT(APCDX,42)=L
+10 SET $EXTRACT(APCDX,47)=$EXTRACT($$VAL^XBDIQ1(9000010,APCDV,.22),1,8)
+11 SET $EXTRACT(APCDX,56)=$PIECE(^AUPNVSIT(APCDV,0),U,7)
+12 SET $EXTRACT(APCDX,58)=$$CLINIC^APCLV(APCDV,"C")
+13 SET $EXTRACT(APCDX,61)=$$MCP(APCDV)
+14 SET $EXTRACT(APCDX,66)=$EXTRACT($$PRIMPROV^APCLV(APCDV,"N"),1,9)
+15 SET L=$PIECE($GET(^AUPNVSIT(APCDV,11)),U,11)
+16 SET $EXTRACT(APCDX,76)=L
+17 SET $EXTRACT(APCDX,78)=APCDERR
+18 QUIT
+19 ;
ERRORCHK(V) ;EP
+1 NEW E,X,C
+2 SET E=""
+3 IF $PIECE(^AUPNVSIT(V,0),U,7)="E"
QUIT ""
+4 IF $PIECE(^AUPNVSIT(V,0),U,7)'="I"
IF '$DATA(^AUPNVPOV("AD",V))
SET E="NO POV"
+5 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 IF $$VAL^XBDIQ1(9000010.07,X,.01)=".9999"
IF E]""
SET E=E_","
SET E=".9999 POV"
QUIT
+7 IF $$VAL^XBDIQ1(9000010.07,X,.01)="ZZZ.999"
IF E]""
SET E=E_","
SET E="ZZZ.999 POV"
End DoDot:1
+8 SET X=0
SET C=0
FOR
SET X=$ORDER(^AUPNVPRV("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+9 IF $PIECE(^AUPNVPRV(X,0),U,4)="P"
SET C=C+1
End DoDot:1
+10 IF C>1
IF E]""
SET E=E_","
SET E=E_"MULT PRIM PROV"
+11 IF $$FINDPEND^APCDCAF6(V)
IF E]""
SET E=E_","
SET E=E_"CHART DEFICIENCIES"
+12 QUIT E
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 ;
IF $GET(F)=""
SET F="I"
+2 IF '$DATA(^AUPNVCA(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 X=A(L)
+10 QUIT $SELECT(F="I":$PIECE(^AUPNVCA(X,0),U,5),1:$$VAL^XBDIQ1(9000010.45,X,.05))
+11 ;
MCP(V) ;
+1 NEW R
SET R=""
+2 IF V=""
QUIT ""
+3 IF '$DATA(^AUPNVSIT(V,0))
QUIT ""
+4 NEW D
+5 SET D=$PIECE(^AUPNVSIT(V,0),U,5)
+6 IF D=""
QUIT ""
+7 IF $$MCR^AUPNPAT(D,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
SET R="M"
+8 IF $$MCD^AUPNPAT(D,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
IF R]""
SET R=R_"/"
SET R=R_"C"
+9 IF $$PI^AUPNPAT(D,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
IF R]""
SET R=R_"/"
SET R=R_"P"
+10 QUIT R
SORT(V,S) ;
+1 NEW R
+2 SET R=""
+3 DO @(S_"SORT")
+4 IF R=""
SET R="ZZZZZZZZ"
+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 ;
ISORT ;
+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 $$MCR^AUPNPAT(D,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
SET R="M"
+6 IF $$MCD^AUPNPAT(D,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
IF R]""
SET R=R_"/"
SET R=R_"C"
+7 IF $$PI^AUPNPAT(D,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
IF R]""
SET R=R_"/"
SET R=R_"P"
+8 QUIT
BACK ;EP go back
+1 DO TERM^VALM0
+2 SET VALMBCK="R"
+3 DO INIT
+4 DO HDR
+5 KILL DIR
+6 KILL X,Y,Z,I
+7 QUIT
+8 ;
NOTEDISP ;
+1 KILL DIR
+2 IF $TEXT(BROWS1^TIURA2)=""
WRITE !!,"TIU not installed"
DO EOP
GOTO NOTEX
+3 SET DIR(0)="NO^1:"_APCDRCNT
SET DIR("A")="Display Note for which Visit"
+4 DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+5 IF Y=""
WRITE !,"No VISIT selected."
DO EOP
GOTO NOTEX
+6 IF $DATA(DIRUT)
WRITE !,"No VISIT selected."
DO EOP
GOTO NOTEX
+7 SET APCDVSIT=^TMP("APCDCAF",$JOB,"IDX",Y,Y)
+8 DO FULL^VALM1
+9 IF '$DATA(^AUPNVNOT("AD",APCDVSIT))
WRITE !!,"That visit does not have any notes to view"
DO EOP
GOTO NOTEX
+10 SET (C,X)=0
FOR
SET X=$ORDER(^AUPNVNOT("AD",APCDVSIT,X))
IF X'=+X
QUIT
SET C=C+1
+11 IF C=1
SET APCDVNOT=$ORDER(^AUPNVNOT("AD",APCDVSIT,0))
DO NOTE1
GOTO NOTEX
+12 ;
MNOTE ;
+1 WRITE !!,"There are more than one note associated with this visit.",!,"Please choose which note to display.",!
+2 KILL APCDN
+3 SET (X,C)=0
FOR
SET X=$ORDER(^AUPNVNOT("AD",APCDVSIT,X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+4 WRITE !?3,C,") ",$$VAL^XBDIQ1(9000010.28,X,.01),?40,$$VAL^XBDIQ1(9000010.28,X,1202)
+5 SET APCDN(C)=X
+6 QUIT
End DoDot:1
+7 KILL DIR
+8 SET DIR(0)="NO^1:"_C
SET DIR("A")="Display which Note"
+9 DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+10 IF Y=""
GOTO NOTEX
+11 IF $DATA(DIRUT)
GOTO NOTEX
+12 SET APCDVNOT=APCDN(Y)
NOTE1 ;
+1 SET APCDTIU=$PIECE(^AUPNVNOT(APCDVNOT,0),U)
+2 DO BROWS1^TIURA2("TIU BROWSE FOR READ ONLY",APCDTIU)
+3 ;
NOTEX ;
+1 KILL DIR,DIRUT,DUOUT,Y,APCDVSIT,APCDVNOT,X,APCDTIU
+2 DO KILL^AUPNPAT
+3 DO BACK
+4 QUIT
+5 ;
CASHX ;EP
+1 DO FULL^VALM1
+2 KILL DIR
+3 SET DIR(0)="NO^1:"_APCDRCNT
SET DIR("A")="Display Chart Audit History for which Visit"
+4 DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+5 IF Y=""
WRITE !,"No VISIT selected."
DO EOP
GOTO CASHXX
+6 IF $DATA(DIRUT)
WRITE !,"No VISIT selected."
DO EOP
GOTO CASHXX
+7 SET APCDVSIT=^TMP("APCDCAF",$JOB,"IDX",Y,Y)
+8 DO VIEWR^XBLM("DCAH^APCDCAF")
+9 ;
CASHXX ;
+1 KILL DIR,DIRUT,DUOUT,Y,APCDVSIT
+2 DO BACK
+3 QUIT
DCAH ;
+1 ;
+2 WRITE !!,"Chart Audit History for VISIT:"
+3 WRITE !?1,"Visit Date: ",$$VAL^XBDIQ1(9000010,APCDVSIT,.01)," Patient Name: ",$$VAL^XBDIQ1(9000010,APCDVSIT,.05)
+4 WRITE !?1,"Hospital Location: ",$$VAL^XBDIQ1(9000010,APCDVSIT,.22)," Primary Provider: ",$$PRIMPROV^APCLV(APCDVSIT,"N")
+5 WRITE !!,"DATE OF AUDIT",?24,"STATUS",?40,"USER WHO AUDITED"
+6 SET APCDX=0
FOR
SET APCDX=$ORDER(^AUPNVCA("AD",APCDVSIT,APCDX))
IF APCDX'=+APCDX
QUIT
Begin DoDot:1
+7 WRITE !,$$GET1^DIQ(9000010.45,APCDX,.01),?24,$$GET1^DIQ(9000010.45,APCDX,.04),?40,$$GET1^DIQ(9000010.45,APCDX,.05)
End DoDot:1
+8 WRITE !!,"DEFICIENCY HISTORY"
+9 WRITE !,"=================="
+10 SET APCDX=0
FOR
SET APCDX=$ORDER(^AUPNVCA("AD",APCDVSIT,APCDX))
IF APCDX'=+APCDX
QUIT
Begin DoDot:1
+11 IF $PIECE(^AUPNVCA(APCDX,0),U,6)=""
QUIT
+12 WRITE !,$$GET1^DIQ(9000010.45,APCDX,.06),?31,$$DATE^APCDCAFA($PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")),?42,$EXTRACT($$GET1^DIQ(9000010.45,APCDX,.05),1,18)
End DoDot:1
+13 SET DA=APCDVSIT
SET DIC="^AUPNCANT("
DO EN^DIQ
+14 QUIT
RESORT ;
+1 DO FULL^VALM1
+2 WRITE !!,"Resorting Visit List",!
+3 SET DIR(0)="S^N:Patient Name;H:HRN;D:Date of Visit;T:Terminal Digit of HRN;S:Service Category;L:Location of Encounter;C:Clinic;O:Hospital Location;P:Primary Provider"
+4 SET DIR(0)=DIR(0)_";A:Chart Audit Status;I:Has Medicare/Medicaid or PI"
+5 SET DIR("A")="How would you like the list of visits sorted"
SET DIR("B")="D"
KILL DA
DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
GOTO RESORTX
+7 SET APCDSORT=Y
+8 ;
RESORTX ;
+1 DO BACK
+2 QUIT
+3 ;
HS ;
+1 DO FULL^VALM1
+2 IF $GET(APCDCAFP)
SET (DFN,APCHSPAT,APCDPAT,Y)=APCDCAFP
GOTO HS1
+3 KILL DIR
+4 SET DIR(0)="NO^1:"_APCDRCNT
SET DIR("A")="Select Visit for Patient's Health summary"
+5 DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+6 IF Y=""
WRITE !,"No VISIT selected."
DO EOP
GOTO HSX
+7 IF $DATA(DIRUT)
WRITE !,"No VISIT selected."
DO EOP
GOTO HSX
+8 SET APCDVSIT=^TMP("APCDCAF",$JOB,"IDX",Y,Y)
+9 SET (Y,APCDPAT,DFN,APCHSPAT)=$PIECE(^AUPNVSIT(APCDVSIT,0),U,5)
HS1 ;
+1 SET X=""
IF DUZ(2)
IF $DATA(^APCCCTRL(DUZ(2),0))#2
SET X=$PIECE(^(0),U,3)
IF X
IF $DATA(^APCHSCTL(X,0))
SET X=$PIECE(^APCHSCTL(X,0),U)
+2 IF $DATA(^DISV(DUZ,"^APCHSCTL("))
SET Y=^("^APCHSCTL(")
IF $DATA(^APCHSCTL(Y,0))
SET X=$PIECE(^(0),U,1)
+3 IF X=""
SET X="ADULT REGULAR"
+4 KILL DIC,DR,DD
SET DIC("B")=X
SET DIC="^APCHSCTL("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DD,D0,D1,DQ
+5 IF Y=-1
DO EOP
GOTO HSX
+6 SET APCHSTYP=+Y
SET APCHSPAT=DFN
+7 SET APCDHDR="PCC Health Summary for "_$PIECE(^DPT(APCHSPAT,0),U)
+8 DO VIEWR^XBLM("EN^APCHS",APCDHDR)
HSX ;
+1 KILL APCDVSIT,APCDPAT,X,Y,AUPNVSIT,AUPNDAYS,DFN,APCDHDR,APCDPLPT
+2 DO EN^XBVK("APCH")
+3 DO KILL^AUPNPAT
+4 DO BACK
+5 QUIT
+6 ;
EOP ;EP
+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 ;
BH ;EP
+1 KILL DIR
+2 IF '$DATA(^XUSEC("AMHZ CODING REVIEW",DUZ))
WRITE !!,"You do not have the security access to see Behavioral Health Notes.",!,"Please see your supervisor for access. The security key needed is AMHZ CODING REVIEW.",!
DO PAUSE^APCDALV1
DO BHX
QUIT
+3 SET DIR(0)="NO^1:"_APCDRCNT
SET DIR("A")="Display Behavioral Health Note for which Visit"
+4 DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+5 IF Y=""
WRITE !,"No VISIT selected."
DO EOP
GOTO BHX
+6 IF $DATA(DIRUT)
WRITE !,"No VISIT selected."
DO EOP
GOTO BHX
+7 SET APCDVSIT=^TMP("APCDCAF",$JOB,"IDX",Y,Y)
+8 DO FULL^VALM1
+9 IF '$DATA(^AMHREC("AVISIT",APCDVSIT))
Begin DoDot:1
+10 WRITE !!,"There is no visit in the Behavioral Health module that is associated"
+11 WRITE !,"with this visit. Use the N - Note Display action to display notes for "
+12 WRITE !,"non-BH visits."
+13 DO EOP
End DoDot:1
GOTO BHX
+14 SET APCDVBH=$ORDER(^AMHREC("AVISIT",APCDVSIT,0))
+15 IF '$DATA(^AUPNVNOT("AD",APCDVSIT))
GOTO BHSOAP
+16 SET (C,X)=0
FOR
SET X=$ORDER(^AUPNVNOT("AD",APCDVSIT,X))
IF X'=+X
QUIT
SET C=C+1
+17 IF C=1
SET APCDVNOT=$ORDER(^AUPNVNOT("AD",APCDVSIT,0))
DO BH1
GOTO BHSOAP
+18 ;
BHM ;
+1 WRITE !!,"There are more than one note associated with this visit.",!,"Please choose which note to display.",!
+2 KILL APCDN
+3 SET (X,C)=0
FOR
SET X=$ORDER(^AUPNVNOT("AD",APCDVSIT,X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+4 WRITE !?3,C,") ",$$VAL^XBDIQ1(9000010.28,X,.01),?40,$$VAL^XBDIQ1(9000010.28,X,1202)
+5 SET APCDN(C)=X
+6 QUIT
End DoDot:1
+7 KILL DIR
+8 SET DIR(0)="NO^1:"_C
SET DIR("A")="Display which Note"
+9 DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+10 IF Y=""
GOTO BHSOAP
+11 IF $DATA(DIRUT)
GOTO BHSOAP
+12 SET APCDVNOT=APCDN(Y)
BH1 ;
+1 SET APCDTIU=$PIECE(^AUPNVNOT(APCDVNOT,0),U)
+2 DO BROWS1^TIURA2("TIU BROWSE FOR READ ONLY",APCDTIU)
+3 ;
BHSOAP ;look for SOAP note
+1 IF $ORDER(^AMHREC(APCDVBH,31,0))
Begin DoDot:1
+2 WRITE !!,"The SOAP note from the Behavioral Health module will now be displayed."
+3 WRITE !!
SET DIR(0)="Y"
SET DIR("A")="Do you want to continue"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
QUIT
+5 IF 'Y
QUIT
+6 DO ARRAY^XBLM("^AMHREC("_APCDVBH_",31,","Behavior Health SOAP Note for visit: "_$$VAL^XBDIQ1(9002011,APCDVBH,.01))
+7 QUIT
End DoDot:1
BHX ;
+1 KILL DIR,DIRUT,DUOUT,Y,APCDVSIT,APCDVNOT,X,APCDTIU
+2 DO KILL^AUPNPAT
+3 DO BACK
+4 QUIT
