APCDCAF2 ; IHS/CMI/LAB - MENTAL HLTH ROUTINE 16-AUG-1994 ;
;;2.0;IHS PCC SUITE;**2,7,8,11**;MAY 14, 2009;Build 58
;; ;
;
EN ; EP -- main entry point for CHART AUDIT LISTMANAGER DISPLAY
S VALMCC=1
NEW VALMCNT
D TERM^VALM0
D CLEAR^VALM1
D EN^VALM("APCDCAF OP MAIN VIEW")
D CLEAR^VALM1
K ^TMP($J),^TMP("APCDCAF OP",$J)
Q
;
HDR ;EP -- header code
S X=" #",$E(X,6)="VISIT DATE",$E(X,21)="PATIENT NAME",$E(X,38)="HRN",$E(X,44)="FAC",$E(X,49)="HOSP LOC",$E(X,59)="S",$E(X,61)="CL",$E(X,64)="PRIM PROV",$E(X,75)="STATUS ERROR"
S VALMHDR(2)=X
S VALMHDR(1)="* an asterisk beside the visit number indicates the visit has an error"
Q
;
INIT ;EP -- init variables and list array
S VALMSG="Q - Quit/?? for more actions/+ next/- previous"
D GATHER ;GATHER UP ALL VISITS FOR DISPLAY
D RECDISP ;sort list by desired sort variable and set up listman display
S VALMCNT=APCDRCNT
Q
;
HELP ;EP -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K APCDRCNT,^TMP($J,"APCDCAF OP"),^TMP($J)
Q
;
EXPND ; -- expand code
Q
;
GATHER ;
K ^TMP($J),^TMP("APCDCAF OP",$J)
S APCDODAT=9999999-APCDCAFD,APCDSTOP=9999999-APCDCAFD
S (APCDRCNT,APCDVIEN)=0 F S APCDODAT=$O(^AUPNVSIT("AA",APCDDFN,APCDODAT)) Q:APCDODAT=""!($P(APCDODAT,".")>APCDSTOP) D
.S APCDVIEN=0 F S APCDVIEN=$O(^AUPNVSIT("AA",APCDDFN,APCDODAT,APCDVIEN)) Q:APCDVIEN'=+APCDVIEN D
..S APCDV0=$G(^AUPNVSIT(APCDVIEN,0))
..Q:APCDV0=""
..Q:$P(APCDV0,U,11) ;DELETED
..Q:$P(APCDV0,U,3)="C" ;CONTRACT
..S APCDVLOC=$P(APCDV0,U,6)
..Q:APCDVLOC="" ;no location of encounter
..S ^TMP($J,"APCDCAF OP",APCDVIEN,APCDVIEN)=""
..Q
.Q
Q
RECDISP ;
S APCDSV="" F S APCDSV=$O(^TMP($J,"APCDCAF OP",APCDSV)) Q:APCDSV="" D
.S APCDV=0 F S APCDV=$O(^TMP($J,"APCDCAF OP",APCDSV,APCDV)) Q:APCDV'=+APCDV D
..S APCDRCNT=APCDRCNT+1
..S APCDX="",DFN=$P(^AUPNVSIT(APCDV,0),U,5) D REC
..S ^TMP("APCDCAF OP",$J,APCDRCNT,0)=APCDX
..S ^TMP("APCDCAF OP",$J,"IDX",APCDRCNT,APCDRCNT)=APCDV
K APCDV,APCDX,APCDSV
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^APCDCAF(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,15)
S $E(APCDX,37)=$$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,44)=L
S $E(APCDX,49)=$E($$VAL^XBDIQ1(9000010,APCDV,.22),1,9)
S $E(APCDX,59)=$P(^AUPNVSIT(APCDV,0),U,7)
S $E(APCDX,61)=$$CLINIC^APCLV(APCDV,"C")
S $E(APCDX,64)=$E($$PRIMPROV^APCLV(APCDV,"N"),1,10)
S L=$P($G(^AUPNVSIT(APCDV,11)),U,11)
S $E(APCDX,75)=L
S $E(APCDX,77)=APCDERR
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 X=A(L)
Q $S(F="I":$P(^AUPNVCA(X,0),U,6),1:$$VAL^XBDIQ1(9000010.45,X,.06))
;
BACK ;EP - go back to listman
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 OP",$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 OP",$J,"IDX",Y,Y)
D VIEWR^XBLM("DCAH^APCDCAF")
D EOP
;
CASHXX ;
K DIR,DIRUT,DUOUT,Y,APCDVSIT
D BACK
Q
CDE ;EP
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^APCDCAF G CDEX
I $D(DIRUT) W !,"No VISIT selected." D EOP^APCDCAF G CDEX
S APCDVSIT=^TMP("APCDCAF OP",$J,"IDX",Y,Y)
K VALMBCK
S APCDCAFV=APCDVSIT,APCDPAT=$P(^AUPNVSIT(APCDVSIT,0),U,5) D EN^APCDCAF6(APCDVSIT)
;
CDEX ;
K DIR,DIRUT,DUOUT,Y,APCDVSIT,APCDCAF,APCDCAFV
;
D BACK
Q
;
HS ;
D FULL^VALM1
I $G(APCDDFN) S (DFN,APCHSPAT,APCDPAT,Y)=APCDDFN 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 OP",$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 - 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
;----------
ADDVISIT ;
S APCDCAF("IN CAF W/PATIENT")=APCDDFN
D EN^XBNEW("^APCDEA","APCDCAF")
K APCDCAF
D BACK
Q
BH ;EP
K DIR
;I $T(BROWS1^TIURA2)="" W !!,"TIU not installed" D EOP G NOTEX
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 and display if it exists
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
VAV ;EP - view any visit when in OP
;
Q
CP ;EP - change patient if in one patient
;
D FULL^VALM1
I '$D(APCDPEHR) W !!,"This item is only allowed to be used when you are in the PEHR option." D PAUSE^APCDALV1,BACK^APCDCAF Q
;change patient
W !
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC
I Y<0 D BACK^APCDCAF Q
I $D(APCDPARM),$P(APCDPARM,U,3)="Y" W !?25,"Ok" S %=1 D YN^DICN Q:%'=1
S (DFN,APCDPATF)=+Y
PROC1 ; call listmanager
S APCDCAFP=DFN,APCDBD=$P(^APCCCTRL(DUZ(2),0),U,12),APCDED=DT,APCDPEHR=1
D BACK^APCDCAF
Q
DISP ;EP
D FULL^VALM1
D EN^XBNEW("DISP1^APCDCAF2","VALM*;APCDCAFP;APCDPEHR;DFN")
;
;
DISPX ;
K DIR,DIRUT,DUOUT,Y,APCDVSIT,APCDCAF,APCDCAFV
D KILL^AUPNPAT
D BACK
Q
DISP1 ;
S APCDPAT=DFN
D GETVISIT^APCDDISP
I '$G(APCDVSIT) W !!,"No visit selected." D PAUSE^APCDALV1 Q
D DSPLY^APCDDISP
D PAUSE^APCDALV1
Q
APCDCAF2 ; IHS/CMI/LAB - MENTAL HLTH ROUTINE 16-AUG-1994 ;
+1 ;;2.0;IHS PCC SUITE;**2,7,8,11**;MAY 14, 2009;Build 58
+2 ;; ;
+3 ;
EN ; EP -- main entry point for CHART AUDIT LISTMANAGER DISPLAY
+1 SET VALMCC=1
+2 NEW VALMCNT
+3 DO TERM^VALM0
+4 DO CLEAR^VALM1
+5 DO EN^VALM("APCDCAF OP MAIN VIEW")
+6 DO CLEAR^VALM1
+7 KILL ^TMP($JOB),^TMP("APCDCAF OP",$JOB)
+8 QUIT
+9 ;
HDR ;EP -- header code
+1 SET X=" #"
SET $EXTRACT(X,6)="VISIT DATE"
SET $EXTRACT(X,21)="PATIENT NAME"
SET $EXTRACT(X,38)="HRN"
SET $EXTRACT(X,44)="FAC"
SET $EXTRACT(X,49)="HOSP LOC"
SET $EXTRACT(X,59)="S"
SET $EXTRACT(X,61)="CL"
SET $EXTRACT(X,64)="PRIM PROV"
SET $EXTRACT(X,75)="STATUS ERROR"
+2 SET VALMHDR(2)=X
+3 SET VALMHDR(1)="* an asterisk beside the visit number indicates the visit has an error"
+4 QUIT
+5 ;
INIT ;EP -- init variables and list array
+1 SET VALMSG="Q - Quit/?? for more actions/+ next/- previous"
+2 ;GATHER UP ALL VISITS FOR DISPLAY
DO GATHER
+3 ;sort list by desired sort variable and set up listman display
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,"APCDCAF OP"),^TMP($JOB)
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
GATHER ;
+1 KILL ^TMP($JOB),^TMP("APCDCAF OP",$JOB)
+2 SET APCDODAT=9999999-APCDCAFD
SET APCDSTOP=9999999-APCDCAFD
+3 SET (APCDRCNT,APCDVIEN)=0
FOR
SET APCDODAT=$ORDER(^AUPNVSIT("AA",APCDDFN,APCDODAT))
IF APCDODAT=""!($PIECE(APCDODAT,".")>APCDSTOP)
QUIT
Begin DoDot:1
+4 SET APCDVIEN=0
FOR
SET APCDVIEN=$ORDER(^AUPNVSIT("AA",APCDDFN,APCDODAT,APCDVIEN))
IF APCDVIEN'=+APCDVIEN
QUIT
Begin DoDot:2
+5 SET APCDV0=$GET(^AUPNVSIT(APCDVIEN,0))
+6 IF APCDV0=""
QUIT
+7 ;DELETED
IF $PIECE(APCDV0,U,11)
QUIT
+8 ;CONTRACT
IF $PIECE(APCDV0,U,3)="C"
QUIT
+9 SET APCDVLOC=$PIECE(APCDV0,U,6)
+10 ;no location of encounter
IF APCDVLOC=""
QUIT
+11 SET ^TMP($JOB,"APCDCAF OP",APCDVIEN,APCDVIEN)=""
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT
RECDISP ;
+1 SET APCDSV=""
FOR
SET APCDSV=$ORDER(^TMP($JOB,"APCDCAF OP",APCDSV))
IF APCDSV=""
QUIT
Begin DoDot:1
+2 SET APCDV=0
FOR
SET APCDV=$ORDER(^TMP($JOB,"APCDCAF OP",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 OP",$JOB,APCDRCNT,0)=APCDX
+6 SET ^TMP("APCDCAF OP",$JOB,"IDX",APCDRCNT,APCDRCNT)=APCDV
End DoDot:2
End DoDot:1
+7 KILL APCDV,APCDX,APCDSV
+8 QUIT
+9 ;
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^APCDCAF(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,15)
+6 SET $EXTRACT(APCDX,37)=$$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,44)=L
+10 SET $EXTRACT(APCDX,49)=$EXTRACT($$VAL^XBDIQ1(9000010,APCDV,.22),1,9)
+11 SET $EXTRACT(APCDX,59)=$PIECE(^AUPNVSIT(APCDV,0),U,7)
+12 SET $EXTRACT(APCDX,61)=$$CLINIC^APCLV(APCDV,"C")
+13 SET $EXTRACT(APCDX,64)=$EXTRACT($$PRIMPROV^APCLV(APCDV,"N"),1,10)
+14 SET L=$PIECE($GET(^AUPNVSIT(APCDV,11)),U,11)
+15 SET $EXTRACT(APCDX,75)=L
+16 SET $EXTRACT(APCDX,77)=APCDERR
+17 QUIT
+18 ;
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 X=A(L)
+10 QUIT $SELECT(F="I":$PIECE(^AUPNVCA(X,0),U,6),1:$$VAL^XBDIQ1(9000010.45,X,.06))
+11 ;
BACK ;EP - go back to listman
+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 OP",$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 OP",$JOB,"IDX",Y,Y)
+8 DO VIEWR^XBLM("DCAH^APCDCAF")
+9 DO EOP
+10 ;
CASHXX ;
+1 KILL DIR,DIRUT,DUOUT,Y,APCDVSIT
+2 DO BACK
+3 QUIT
CDE ;EP
+1 KILL DIR
+2 SET DIR(0)="NO^1:"_APCDRCNT
SET DIR("A")="Which Visit"
+3 DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+4 IF Y=""
WRITE !,"No VISIT selected."
DO EOP^APCDCAF
GOTO CDEX
+5 IF $DATA(DIRUT)
WRITE !,"No VISIT selected."
DO EOP^APCDCAF
GOTO CDEX
+6 SET APCDVSIT=^TMP("APCDCAF OP",$JOB,"IDX",Y,Y)
+7 KILL VALMBCK
+8 SET APCDCAFV=APCDVSIT
SET APCDPAT=$PIECE(^AUPNVSIT(APCDVSIT,0),U,5)
DO EN^APCDCAF6(APCDVSIT)
+9 ;
CDEX ;
+1 KILL DIR,DIRUT,DUOUT,Y,APCDVSIT,APCDCAF,APCDCAFV
+2 ;
+3 DO BACK
+4 QUIT
+5 ;
HS ;
+1 DO FULL^VALM1
+2 IF $GET(APCDDFN)
SET (DFN,APCHSPAT,APCDPAT,Y)=APCDDFN
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 OP",$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 - 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 ;----------
ADDVISIT ;
+1 SET APCDCAF("IN CAF W/PATIENT")=APCDDFN
+2 DO EN^XBNEW("^APCDEA","APCDCAF")
+3 KILL APCDCAF
+4 DO BACK
+5 QUIT
BH ;EP
+1 KILL DIR
+2 ;I $T(BROWS1^TIURA2)="" W !!,"TIU not installed" D EOP G NOTEX
+3 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
+4 SET DIR(0)="NO^1:"_APCDRCNT
SET DIR("A")="Display Behavioral Health Note for which Visit"
+5 DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+6 IF Y=""
WRITE !,"No VISIT selected."
DO EOP
GOTO BHX
+7 IF $DATA(DIRUT)
WRITE !,"No VISIT selected."
DO EOP
GOTO BHX
+8 SET APCDVSIT=^TMP("APCDCAF",$JOB,"IDX",Y,Y)
+9 DO FULL^VALM1
+10 IF '$DATA(^AMHREC("AVISIT",APCDVSIT))
Begin DoDot:1
+11 WRITE !!,"There is no visit in the Behavioral Health module that is associated"
+12 WRITE !,"with this visit. Use the N - Note Display action to display notes for "
+13 WRITE !,"non-BH visits."
+14 DO EOP
End DoDot:1
GOTO BHX
+15 SET APCDVBH=$ORDER(^AMHREC("AVISIT",APCDVSIT,0))
+16 IF '$DATA(^AUPNVNOT("AD",APCDVSIT))
GOTO BHSOAP
+17 SET (C,X)=0
FOR
SET X=$ORDER(^AUPNVNOT("AD",APCDVSIT,X))
IF X'=+X
QUIT
SET C=C+1
+18 IF C=1
SET APCDVNOT=$ORDER(^AUPNVNOT("AD",APCDVSIT,0))
DO BH1
GOTO BHSOAP
+19 ;
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 and display if it exists
+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
VAV ;EP - view any visit when in OP
+1 ;
+2 QUIT
CP ;EP - change patient if in one patient
+1 ;
+2 DO FULL^VALM1
+3 IF '$DATA(APCDPEHR)
WRITE !!,"This item is only allowed to be used when you are in the PEHR option."
DO PAUSE^APCDALV1
DO BACK^APCDCAF
QUIT
+4 ;change patient
+5 WRITE !
+6 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+7 IF Y<0
DO BACK^APCDCAF
QUIT
+8 IF $DATA(APCDPARM)
IF $PIECE(APCDPARM,U,3)="Y"
WRITE !?25,"Ok"
SET %=1
DO YN^DICN
IF %'=1
QUIT
+9 SET (DFN,APCDPATF)=+Y
PROC1 ; call listmanager
+1 SET APCDCAFP=DFN
SET APCDBD=$PIECE(^APCCCTRL(DUZ(2),0),U,12)
SET APCDED=DT
SET APCDPEHR=1
+2 DO BACK^APCDCAF
+3 QUIT
DISP ;EP
+1 DO FULL^VALM1
+2 DO EN^XBNEW("DISP1^APCDCAF2","VALM*;APCDCAFP;APCDPEHR;DFN")
+3 ;
+4 ;
DISPX ;
+1 KILL DIR,DIRUT,DUOUT,Y,APCDVSIT,APCDCAF,APCDCAFV
+2 DO KILL^AUPNPAT
+3 DO BACK
+4 QUIT
DISP1 ;
+1 SET APCDPAT=DFN
+2 DO GETVISIT^APCDDISP
+3 IF '$GET(APCDVSIT)
WRITE !!,"No visit selected."
DO PAUSE^APCDALV1
QUIT
+4 DO DSPLY^APCDDISP
+5 DO PAUSE^APCDALV1
+6 QUIT
