AMHDPEE ; IHS/CMI/LAB - BROWSE VISITS ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
;
START ;
NEW AMHX,AMHY,AMHR0,DFN,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX,AMHV,AMHBD,AMHED
NEW D,R
K AMHV
W:$D(IOF) @IOF
W $$CTR("View/Update Designated Provider List",80)
PROV ;
D ^XBFMK
S AMHDP=""
W !! S DIC("A")="Enter Designated Provider Name: ",DIC="^VA(200,",DIC(0)="AEMQ",DIC("B")=$P(^VA(200,DUZ,0),U) D ^DIC K DIC,DA,DR,DLAYGO,DIADD
I Y<0 W !,"No Provider Selected." Q
S AMHPROV=+Y
DEMO ;
D DEMOCHK^AMHUTIL1(.AMHDEMO)
I AMHDEMO=-1 G PROV
D EN
END ;
D EOJ
K AMHP,AMHQUIT,AMHW
Q
;
EN ; -- main entry point for AMH UPDATE PATIENT CASE DATA
D EN^VALM("AMH VIEW/UPDATE DP LIST")
K AMHCASE,AMHX,AMHD,AMHRCNT,AMHLINE,AMHCDATE
Q
;
HDR ; -- header code
S VALMHDR(1)=$TR($J(" ",80)," ","-")
S VALMHDR(2)="Patients with Designated Provider: "_IORVON_$P(^VA(200,AMHPROV,0),U)_IOINORM
S VALMHDR(3)=$TR($J(" ",80)," ","-")
S VALMHDR(4)="# HRN PATIENT NAME DOB SEX LAST VISIT PROV TYPE"
Q
;
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
LVD(P,I) ;EP
I $G(I)="" S I="D"
I '$G(P) Q ""
NEW D,A,B,C,G
S G="",A=0 F S A=$O(^AMHREC("AE",P,A)) Q:A'=+A!(G) D
.S (B,F)=0 F S B=$O(^AMHREC("AE",P,A,B)) Q:B'=+B!(G) D
..Q:'$D(^AMHREC(B,0))
..Q:'$$ALLOWVI^AMHUTIL(DUZ,B)
..S (F,C)=0 F S C=$O(^AMHRPRO("AD",B,C)) Q:C'=+C D
...S E=$P(^AMHRPRO(C,0),U),E=$S(E:$P(^AMHPROB(E,0),U),1:"")
...Q:E=""
...Q:E<8!(E>8.99999)
...S F=1 ;got a DNKA
...Q
..I 'F S G=B
..Q
.Q
I 'G Q ""
I I="I" Q G
S D=$P($P(^AMHREC(G,0),U),".") I I="ID" Q D
Q $$FMTE^XLFDT(D)
INIT ; -- init variables and list array
S VALMSG="?? for more actions + next screen - prev screen"
D GATHER ;gather up all records for display
S VALMCNT=AMHLINE
Q
;
GATHER ;
K ^TMP("AMHDPEE",$J),^TMP($J,"AMHDPEE")
S AMHD=0 F S AMHD=$O(^AMHPATR("AMH",AMHPROV,AMHD)) Q:AMHD'=+AMHD I '$$DEMO^AMHUTIL1(AMHD,$G(AMHDEMO)) S ^TMP($J,"AMHDPEE",$P(^DPT(AMHD,0),U),AMHD,1)=""
S AMHD=0 F S AMHD=$O(^AMHPATR("ASS",AMHPROV,AMHD)) Q:AMHD'=+AMHD I '$$DEMO^AMHUTIL1(AMHD,$G(AMHDEMO)) S ^TMP($J,"AMHDPEE",$P(^DPT(AMHD,0),U),AMHD,2)=""
S AMHD=0 F S AMHD=$O(^AMHPATR("AOT",AMHPROV,AMHD)) Q:AMHD'=+AMHD I '$$DEMO^AMHUTIL1(AMHD,$G(AMHDEMO)) S ^TMP($J,"AMHDPEE",$P(^DPT(AMHD,0),U),AMHD,3)=""
S AMHD=0 F S AMHD=$O(^AMHPATR("AOTH",AMHPROV,AMHD)) Q:AMHD'=+AMHD I '$$DEMO^AMHUTIL1(AMHD,$G(AMHDEMO)) S ^TMP($J,"AMHDPEE",$P(^DPT(AMHD,0),U),AMHD,4)=""
;S AMHD=0 F S AMHD=$O(^AMHPATR("AOP",AMHPROV,AMHD)) Q:AMHD'=+AMHD S ^TMP($J,"AMHDPEE",$P(^DPT(AMHD,0),U),AMHD,5)=""
S AMHRCNT=0,AMHLINE=0
S AMHNAME=0 F S AMHNAME=$O(^TMP($J,"AMHDPEE",AMHNAME)) Q:AMHNAME="" D
.S AMHD=0 F S AMHD=$O(^TMP($J,"AMHDPEE",AMHNAME,AMHD)) Q:AMHD'=+AMHD D
..S AMHT=0 F S AMHT=$O(^TMP($J,"AMHDPEE",AMHNAME,AMHD,AMHT)) Q:AMHT'=+AMHT D
...S AMHRCNT=AMHRCNT+1,AMHLINE=AMHLINE+1,Y=AMHRCNT
...S $E(Y,6)=$$HRN^AUPNPAT(AMHD,DUZ(2)),$E(Y,13)=$E($P(^DPT(AMHD,0),U),1,25),$E(Y,39)=$$DOB^AUPNPAT(AMHD,"E"),$E(Y,52)=$P(^DPT(AMHD,0),U,2),$E(Y,56)=$$LVD(AMHD)
...S $E(Y,69)=$S(AMHT=1:"MENTAL HLTH",AMHT=2:"SOC SERV",AMHT=3:"CD/OTH",AMHT=4:"OTHER",AMHT=5:"OTHER 2",1:"")
...S ^TMP("AMHDPEE",$J,AMHLINE,0)=Y,^TMP("AMHDPEE",$J,"IDX",AMHLINE,AMHRCNT)=AMHD
Q ;new
S AMHD=0 F S AMHD=$O(^AMHPATR("ASS",AMHPROV,AMHD)) Q:AMHD'=+AMHD D
.S AMHRCNT=AMHRCNT+1,AMHLINE=AMHLINE+1,Y=AMHRCNT
.S $E(Y,6)=$$HRN^AUPNPAT(AMHD,DUZ(2)),$E(Y,13)=$E($P(^DPT(AMHD,0),U),1,25),$E(Y,39)=$$DOB^AUPNPAT(AMHD,"E"),$E(Y,52)=$P(^DPT(AMHD,0),U,2),$E(Y,56)=$$LVD(AMHD),$E(Y,69)="SOC SERV"
.S ^TMP("AMHDPEE",$J,AMHLINE,0)=Y,^TMP("AMHDPEE",$J,"IDX",AMHLINE,AMHRCNT)=AMHD
S AMHD=0 F S AMHD=$O(^AMHPATR("AOT",AMHPROV,AMHD)) Q:AMHD'=+AMHD D
.S AMHRCNT=AMHRCNT+1,AMHLINE=AMHLINE+1,Y=AMHRCNT
.S $E(Y,6)=$$HRN^AUPNPAT(AMHD,DUZ(2)),$E(Y,13)=$E($P(^DPT(AMHD,0),U),1,25),$E(Y,39)=$$DOB^AUPNPAT(AMHD,"E"),$E(Y,52)=$P(^DPT(AMHD,0),U,2),$E(Y,56)=$$LVD(AMHD),$E(Y,69)="CD/OTH"
.S ^TMP("AMHDPEE",$J,AMHLINE,0)=Y,^TMP("AMHDPEE",$J,"IDX",AMHLINE,AMHRCNT)=AMHD
S AMHD=0 F S AMHD=$O(^AMHPATR("AOTH",AMHPROV,AMHD)) Q:AMHD'=+AMHD D
.S AMHRCNT=AMHRCNT+1,AMHLINE=AMHLINE+1,Y=AMHRCNT
.S $E(Y,6)=$$HRN^AUPNPAT(AMHD,DUZ(2)),$E(Y,13)=$E($P(^DPT(AMHD,0),U),1,25),$E(Y,39)=$$DOB^AUPNPAT(AMHD,"E"),$E(Y,52)=$P(^DPT(AMHD,0),U,2),$E(Y,56)=$$LVD(AMHD),$E(Y,69)="OTHER"
.S ^TMP("AMHDPEE",$J,AMHLINE,0)=Y,^TMP("AMHDPEE",$J,"IDX",AMHLINE,AMHRCNT)=AMHD
;S AMHD=0 F S AMHD=$O(^AMHPATR("AOP",AMHPROV,AMHD)) Q:AMHD'=+AMHD D
;.S AMHRCNT=AMHRCNT+1,AMHLINE=AMHLINE+1,Y=AMHRCNT
;.S $E(Y,6)=$$HRN^AUPNPAT(AMHD,DUZ(2)),$E(Y,13)=$E($P(^DPT(AMHD,0),U),1,25),$E(Y,39)=$$DOB^AUPNPAT(AMHD,"E"),$E(Y,52)=$P(^DPT(AMHD,0),U,2),$E(Y,56)=$$LVD(AMHD),$E(Y,69)="OTH 2"
;.S ^TMP("AMHDPEE",$J,AMHLINE,0)=Y,^TMP("AMHDPEE",$J,"IDX",AMHLINE,AMHRCNT)=AMHD
Q
EDDP ;EP - called from protocol
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." G EXIT
S AMHR=$O(VALMY(0)) I 'AMHR K AMHR,VALMY,XQORNOD W !,"No record selected." G EXIT
S AMHR=^TMP("AMHDPEE",$J,"IDX",AMHR,AMHR) I 'AMHR K AMHRDEL,AMHR D PAUSE^AMHLEA D EXIT Q
I '$D(^AMHPATR(AMHR,0)) W !,"Not a valid PATIENT RECORD." K AMHRDEL,AMHR D PAUSE^AMHLEA D EXIT Q
D FULL^VALM1
W !,"Editing Designated Provider....."
S DA=AMHR,DIE="^AMHPATR(",DR=".02;.03;.04;.12;.13" D ^DIE
D EXIT
Q
RMDP ;EP - called from protocol to remove DP entry
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." G EXIT
S AMHR=$O(VALMY(0)) I 'AMHR K AMHR,VALMY,XQORNOD W !,"No record selected." G EXIT
S AMHR=^TMP("AMHDPEE",$J,"IDX",AMHR,AMHR) I 'AMHR K AMHRDEL,AMHR D PAUSE^AMHLEA D EXIT Q
I '$D(^AMHPATR(AMHR,0)) W !,"Not a valid PATIENT RECORD." K AMHRDEL,AMHR D PAUSE^AMHLEA D EXIT Q
D FULL^VALM1
W !,"Removing ",$P(^VA(200,AMHPROV,0),U)," as Designated Provider for ",!,$P(^DPT($P(^AMHPATR(AMHR,0),U),0),U)," ..."
I $P(^AMHPATR(AMHR,0),U,2)=AMHPROV S DA=AMHR,DIE="^AMHPATR(",DR=".02///@" D ^DIE
I $P(^AMHPATR(AMHR,0),U,3)=AMHPROV S DA=AMHR,DIE="^AMHPATR(",DR=".03///@" D ^DIE
I $P(^AMHPATR(AMHR,0),U,4)=AMHPROV S DA=AMHR,DIE="^AMHPATR(",DR=".04///@" D ^DIE
I $P(^AMHPATR(AMHR,0),U,12)=AMHPROV S DA=AMHR,DIE="^AMHPATR(",DR=".12///@" D ^DIE
;I $P(^AMHPATR(AMHR,0),U,13)=AMHPROV S DA=AMHR,DIE="^AMHPATR(",DR=".13///@" D ^DIE
CD ;
S DIR(0)="Y",DIR("A")="Do you want to update the Case Status?",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D EXIT Q
I 'Y D EXIT Q
D EP1^AMHLCD(AMHR)
D EXIT
Q
BV ;
D ^AMHVD
D EXIT
Q
HS ;EP called from protocol to generate hs
S DFN=""
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD
I Y<0 W !,"No Patient Selected." Q
S DFN=+Y
S Y=DFN D ^AUPNPAT
I $G(AUPNDOD)]"" W !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!! H 2
D GETTYPE
I '$G(APCHSTYP) D EN^XBVK("APCH") Q
S APCHSPAT=DFN
S %="PCC Health Summary for "_$P(^DPT(APCHSPAT,0),U)
D VIEWR^XBLM("EN^APCHS",%)
D EN^XBVK("APCH") K AMCHDAYS,AMCHDOB,%
D EXIT
Q
GETTYPE ;
I $G(^AMHSITE(DUZ(2),0))="" D DEFAULT Q
S APCHSTYP=$P(^AMHSITE(DUZ(2),0),U,4) I APCHSTYP="" D DEFAULT Q
I '$D(^APCHSCTL(APCHSTYP)) W !,"Error in Site Parameter File!",$C(7),$C(7) S APCHSTYP="" Q
Q
DEFAULT ;
S APCHSTYP=""
S X="BEHAVIORAL HEALTH",DIC(0)="",DIC="^APCHSCTL(" D ^DIC K DIC,DA
I Y=-1 W !!,"PCC MENTAL HEALTH HEALTH SUMMARY TYPE IS MISSING!! NOTIFY YOUR SUPERVISOR OR SITE MANAGER.",!! Q
S APCHSTYP=+Y
Q
ADDDP ;EP called from protocol to open a new case
D FULL^VALM1
W:$D(IOF) @IOF
S AMHPAT=""
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD
I Y<0 W !,"No Patient Selected." Q
S AMHPAT=+Y
I '$D(^AMHPATR(AMHPAT)) S DIC="^AMHPATR(",DIC(0)="L",DLAYGO=9002011.55,X="`"_AMHPAT D ^DIC I Y=-1 D ^XBFMK K DLAYGO,DIADD W !!,"FAILED TO ADD PATIENT TO MHSS PATIENT DATA FILE" Q
S DA=AMHPAT,DDSFILE=9002011.55,DR="[AMH PATIENT RELATED DATA]" D ^DDS
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S AMHQUIT=1 K DIMSG Q
D EXIT
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K AMHX,AMHCASE,AMHPC,AMHR1,AMHPAT,DFN
D TERM^VALM0
S VALMBCK="R"
D GATHER
S VALMCNT=AMHLINE
D HDR
K X,Y,Z,I
Q
EOJ ;
D EN^XBVK("AMH")
K DFN
K DDSFILE,DIPGM,Y
K X,Y,%,DR,DDS,DA,DIC
K AMHCASE,AMHX,AMHD,AMHRCNT,AMHLINE,AMHCDATE
D:$D(VALMWD) CLEAR^VALM1
K VALM,VALMHDR,VALMKEY,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMLST,VALMVAR,VALMLFT,VALMBCK,VALMCC,VALMAR,VALMBG,VALMCAP,VALMCOFF,VALMCNT,VALMCON,BALMON,VALMEVL,VALMIOXY
D KILL^AUPNPAT
Q
;
EXPND ; -- expand code
Q
;
AV ;EP add visit
D FULL^VALM1
D GETPAT^AMHLEA
I 'AMHPAT W !,"NO Patient selected!",! D PAUSE^AMHLEA D EXIT Q
S DFN=AMHPAT
S AMHDPEEP=AMHPROV
D CONTACT^AMHLEP1(AMHPAT,1)
S AMHPROV=AMHDPEEP
D PAUSE^AMHLEA
D EXIT
Q
AMHDPEE ; IHS/CMI/LAB - BROWSE VISITS ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
+3 ;
START ;
+1 NEW AMHX,AMHY,AMHR0,DFN,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX,AMHV,AMHBD,AMHED
+2 NEW D,R
+3 KILL AMHV
+4 IF $DATA(IOF)
WRITE @IOF
+5 WRITE $$CTR("View/Update Designated Provider List",80)
PROV ;
+1 DO ^XBFMK
+2 SET AMHDP=""
+3 WRITE !!
SET DIC("A")="Enter Designated Provider Name: "
SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
SET DIC("B")=$PIECE(^VA(200,DUZ,0),U)
DO ^DIC
KILL DIC,DA,DR,DLAYGO,DIADD
+4 IF Y<0
WRITE !,"No Provider Selected."
QUIT
+5 SET AMHPROV=+Y
DEMO ;
+1 DO DEMOCHK^AMHUTIL1(.AMHDEMO)
+2 IF AMHDEMO=-1
GOTO PROV
+3 DO EN
END ;
+1 DO EOJ
+2 KILL AMHP,AMHQUIT,AMHW
+3 QUIT
+4 ;
EN ; -- main entry point for AMH UPDATE PATIENT CASE DATA
+1 DO EN^VALM("AMH VIEW/UPDATE DP LIST")
+2 KILL AMHCASE,AMHX,AMHD,AMHRCNT,AMHLINE,AMHCDATE
+3 QUIT
+4 ;
HDR ; -- header code
+1 SET VALMHDR(1)=$TRANSLATE($JUSTIFY(" ",80)," ","-")
+2 SET VALMHDR(2)="Patients with Designated Provider: "_IORVON_$PIECE(^VA(200,AMHPROV,0),U)_IOINORM
+3 SET VALMHDR(3)=$TRANSLATE($JUSTIFY(" ",80)," ","-")
+4 SET VALMHDR(4)="# HRN PATIENT NAME DOB SEX LAST VISIT PROV TYPE"
+5 QUIT
+6 ;
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 ;----------
LVD(P,I) ;EP
+1 IF $GET(I)=""
SET I="D"
+2 IF '$GET(P)
QUIT ""
+3 NEW D,A,B,C,G
+4 SET G=""
SET A=0
FOR
SET A=$ORDER(^AMHREC("AE",P,A))
IF A'=+A!(G)
QUIT
Begin DoDot:1
+5 SET (B,F)=0
FOR
SET B=$ORDER(^AMHREC("AE",P,A,B))
IF B'=+B!(G)
QUIT
Begin DoDot:2
+6 IF '$DATA(^AMHREC(B,0))
QUIT
+7 IF '$$ALLOWVI^AMHUTIL(DUZ,B)
QUIT
+8 SET (F,C)=0
FOR
SET C=$ORDER(^AMHRPRO("AD",B,C))
IF C'=+C
QUIT
Begin DoDot:3
+9 SET E=$PIECE(^AMHRPRO(C,0),U)
SET E=$SELECT(E:$PIECE(^AMHPROB(E,0),U),1:"")
+10 IF E=""
QUIT
+11 IF E<8!(E>8.99999)
QUIT
+12 ;got a DNKA
SET F=1
+13 QUIT
End DoDot:3
+14 IF 'F
SET G=B
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 IF 'G
QUIT ""
+18 IF I="I"
QUIT G
+19 SET D=$PIECE($PIECE(^AMHREC(G,0),U),".")
IF I="ID"
QUIT D
+20 QUIT $$FMTE^XLFDT(D)
INIT ; -- init variables and list array
+1 SET VALMSG="?? for more actions + next screen - prev screen"
+2 ;gather up all records for display
DO GATHER
+3 SET VALMCNT=AMHLINE
+4 QUIT
+5 ;
GATHER ;
+1 KILL ^TMP("AMHDPEE",$JOB),^TMP($JOB,"AMHDPEE")
+2 SET AMHD=0
FOR
SET AMHD=$ORDER(^AMHPATR("AMH",AMHPROV,AMHD))
IF AMHD'=+AMHD
QUIT
IF '$$DEMO^AMHUTIL1(AMHD,$GET(AMHDEMO))
SET ^TMP($JOB,"AMHDPEE",$PIECE(^DPT(AMHD,0),U),AMHD,1)=""
+3 SET AMHD=0
FOR
SET AMHD=$ORDER(^AMHPATR("ASS",AMHPROV,AMHD))
IF AMHD'=+AMHD
QUIT
IF '$$DEMO^AMHUTIL1(AMHD,$GET(AMHDEMO))
SET ^TMP($JOB,"AMHDPEE",$PIECE(^DPT(AMHD,0),U),AMHD,2)=""
+4 SET AMHD=0
FOR
SET AMHD=$ORDER(^AMHPATR("AOT",AMHPROV,AMHD))
IF AMHD'=+AMHD
QUIT
IF '$$DEMO^AMHUTIL1(AMHD,$GET(AMHDEMO))
SET ^TMP($JOB,"AMHDPEE",$PIECE(^DPT(AMHD,0),U),AMHD,3)=""
+5 SET AMHD=0
FOR
SET AMHD=$ORDER(^AMHPATR("AOTH",AMHPROV,AMHD))
IF AMHD'=+AMHD
QUIT
IF '$$DEMO^AMHUTIL1(AMHD,$GET(AMHDEMO))
SET ^TMP($JOB,"AMHDPEE",$PIECE(^DPT(AMHD,0),U),AMHD,4)=""
+6 ;S AMHD=0 F S AMHD=$O(^AMHPATR("AOP",AMHPROV,AMHD)) Q:AMHD'=+AMHD S ^TMP($J,"AMHDPEE",$P(^DPT(AMHD,0),U),AMHD,5)=""
+7 SET AMHRCNT=0
SET AMHLINE=0
+8 SET AMHNAME=0
FOR
SET AMHNAME=$ORDER(^TMP($JOB,"AMHDPEE",AMHNAME))
IF AMHNAME=""
QUIT
Begin DoDot:1
+9 SET AMHD=0
FOR
SET AMHD=$ORDER(^TMP($JOB,"AMHDPEE",AMHNAME,AMHD))
IF AMHD'=+AMHD
QUIT
Begin DoDot:2
+10 SET AMHT=0
FOR
SET AMHT=$ORDER(^TMP($JOB,"AMHDPEE",AMHNAME,AMHD,AMHT))
IF AMHT'=+AMHT
QUIT
Begin DoDot:3
+11 SET AMHRCNT=AMHRCNT+1
SET AMHLINE=AMHLINE+1
SET Y=AMHRCNT
+12 SET $EXTRACT(Y,6)=$$HRN^AUPNPAT(AMHD,DUZ(2))
SET $EXTRACT(Y,13)=$EXTRACT($PIECE(^DPT(AMHD,0),U),1,25)
SET $EXTRACT(Y,39)=$$DOB^AUPNPAT(AMHD,"E")
SET $EXTRACT(Y,52)=$PIECE(^DPT(AMHD,0),U,2)
SET $EXTRACT(Y,56)=$$LVD(AMHD)
+13 SET $EXTRACT(Y,69)=$SELECT(AMHT=1:"MENTAL HLTH",AMHT=2:"SOC SERV",AMHT=3:"CD/OTH",AMHT=4:"OTHER",AMHT=5:"OTHER 2",1:"")
+14 SET ^TMP("AMHDPEE",$JOB,AMHLINE,0)=Y
SET ^TMP("AMHDPEE",$JOB,"IDX",AMHLINE,AMHRCNT)=AMHD
End DoDot:3
End DoDot:2
End DoDot:1
+15 ;new
QUIT
+16 SET AMHD=0
FOR
SET AMHD=$ORDER(^AMHPATR("ASS",AMHPROV,AMHD))
IF AMHD'=+AMHD
QUIT
Begin DoDot:1
+17 SET AMHRCNT=AMHRCNT+1
SET AMHLINE=AMHLINE+1
SET Y=AMHRCNT
+18 SET $EXTRACT(Y,6)=$$HRN^AUPNPAT(AMHD,DUZ(2))
SET $EXTRACT(Y,13)=$EXTRACT($PIECE(^DPT(AMHD,0),U),1,25)
SET $EXTRACT(Y,39)=$$DOB^AUPNPAT(AMHD,"E")
SET $EXTRACT(Y,52)=$PIECE(^DPT(AMHD,0),U,2)
SET $EXTRACT(Y,56)=$$LVD(AMHD)
SET $EXTRACT(Y,69)="SOC SERV"
+19 SET ^TMP("AMHDPEE",$JOB,AMHLINE,0)=Y
SET ^TMP("AMHDPEE",$JOB,"IDX",AMHLINE,AMHRCNT)=AMHD
End DoDot:1
+20 SET AMHD=0
FOR
SET AMHD=$ORDER(^AMHPATR("AOT",AMHPROV,AMHD))
IF AMHD'=+AMHD
QUIT
Begin DoDot:1
+21 SET AMHRCNT=AMHRCNT+1
SET AMHLINE=AMHLINE+1
SET Y=AMHRCNT
+22 SET $EXTRACT(Y,6)=$$HRN^AUPNPAT(AMHD,DUZ(2))
SET $EXTRACT(Y,13)=$EXTRACT($PIECE(^DPT(AMHD,0),U),1,25)
SET $EXTRACT(Y,39)=$$DOB^AUPNPAT(AMHD,"E")
SET $EXTRACT(Y,52)=$PIECE(^DPT(AMHD,0),U,2)
SET $EXTRACT(Y,56)=$$LVD(AMHD)
SET $EXTRACT(Y,69)="CD/OTH"
+23 SET ^TMP("AMHDPEE",$JOB,AMHLINE,0)=Y
SET ^TMP("AMHDPEE",$JOB,"IDX",AMHLINE,AMHRCNT)=AMHD
End DoDot:1
+24 SET AMHD=0
FOR
SET AMHD=$ORDER(^AMHPATR("AOTH",AMHPROV,AMHD))
IF AMHD'=+AMHD
QUIT
Begin DoDot:1
+25 SET AMHRCNT=AMHRCNT+1
SET AMHLINE=AMHLINE+1
SET Y=AMHRCNT
+26 SET $EXTRACT(Y,6)=$$HRN^AUPNPAT(AMHD,DUZ(2))
SET $EXTRACT(Y,13)=$EXTRACT($PIECE(^DPT(AMHD,0),U),1,25)
SET $EXTRACT(Y,39)=$$DOB^AUPNPAT(AMHD,"E")
SET $EXTRACT(Y,52)=$PIECE(^DPT(AMHD,0),U,2)
SET $EXTRACT(Y,56)=$$LVD(AMHD)
SET $EXTRACT(Y,69)="OTHER"
+27 SET ^TMP("AMHDPEE",$JOB,AMHLINE,0)=Y
SET ^TMP("AMHDPEE",$JOB,"IDX",AMHLINE,AMHRCNT)=AMHD
End DoDot:1
+28 ;S AMHD=0 F S AMHD=$O(^AMHPATR("AOP",AMHPROV,AMHD)) Q:AMHD'=+AMHD D
+29 ;.S AMHRCNT=AMHRCNT+1,AMHLINE=AMHLINE+1,Y=AMHRCNT
+30 ;.S $E(Y,6)=$$HRN^AUPNPAT(AMHD,DUZ(2)),$E(Y,13)=$E($P(^DPT(AMHD,0),U),1,25),$E(Y,39)=$$DOB^AUPNPAT(AMHD,"E"),$E(Y,52)=$P(^DPT(AMHD,0),U,2),$E(Y,56)=$$LVD(AMHD),$E(Y,69)="OTH 2"
+31 ;.S ^TMP("AMHDPEE",$J,AMHLINE,0)=Y,^TMP("AMHDPEE",$J,"IDX",AMHLINE,AMHRCNT)=AMHD
+32 QUIT
EDDP ;EP - called from protocol
+1 DO EN^VALM2(XQORNOD(0),"OS")
+2 IF '$DATA(VALMY)
WRITE !,"No records selected."
GOTO EXIT
+3 SET AMHR=$ORDER(VALMY(0))
IF 'AMHR
KILL AMHR,VALMY,XQORNOD
WRITE !,"No record selected."
GOTO EXIT
+4 SET AMHR=^TMP("AMHDPEE",$JOB,"IDX",AMHR,AMHR)
IF 'AMHR
KILL AMHRDEL,AMHR
DO PAUSE^AMHLEA
DO EXIT
QUIT
+5 IF '$DATA(^AMHPATR(AMHR,0))
WRITE !,"Not a valid PATIENT RECORD."
KILL AMHRDEL,AMHR
DO PAUSE^AMHLEA
DO EXIT
QUIT
+6 DO FULL^VALM1
+7 WRITE !,"Editing Designated Provider....."
+8 SET DA=AMHR
SET DIE="^AMHPATR("
SET DR=".02;.03;.04;.12;.13"
DO ^DIE
+9 DO EXIT
+10 QUIT
RMDP ;EP - called from protocol to remove DP entry
+1 DO EN^VALM2(XQORNOD(0),"OS")
+2 IF '$DATA(VALMY)
WRITE !,"No records selected."
GOTO EXIT
+3 SET AMHR=$ORDER(VALMY(0))
IF 'AMHR
KILL AMHR,VALMY,XQORNOD
WRITE !,"No record selected."
GOTO EXIT
+4 SET AMHR=^TMP("AMHDPEE",$JOB,"IDX",AMHR,AMHR)
IF 'AMHR
KILL AMHRDEL,AMHR
DO PAUSE^AMHLEA
DO EXIT
QUIT
+5 IF '$DATA(^AMHPATR(AMHR,0))
WRITE !,"Not a valid PATIENT RECORD."
KILL AMHRDEL,AMHR
DO PAUSE^AMHLEA
DO EXIT
QUIT
+6 DO FULL^VALM1
+7 WRITE !,"Removing ",$PIECE(^VA(200,AMHPROV,0),U)," as Designated Provider for ",!,$PIECE(^DPT($PIECE(^AMHPATR(AMHR,0),U),0),U)," ..."
+8 IF $PIECE(^AMHPATR(AMHR,0),U,2)=AMHPROV
SET DA=AMHR
SET DIE="^AMHPATR("
SET DR=".02///@"
DO ^DIE
+9 IF $PIECE(^AMHPATR(AMHR,0),U,3)=AMHPROV
SET DA=AMHR
SET DIE="^AMHPATR("
SET DR=".03///@"
DO ^DIE
+10 IF $PIECE(^AMHPATR(AMHR,0),U,4)=AMHPROV
SET DA=AMHR
SET DIE="^AMHPATR("
SET DR=".04///@"
DO ^DIE
+11 IF $PIECE(^AMHPATR(AMHR,0),U,12)=AMHPROV
SET DA=AMHR
SET DIE="^AMHPATR("
SET DR=".12///@"
DO ^DIE
+12 ;I $P(^AMHPATR(AMHR,0),U,13)=AMHPROV S DA=AMHR,DIE="^AMHPATR(",DR=".13///@" D ^DIE
CD ;
+1 SET DIR(0)="Y"
SET DIR("A")="Do you want to update the Case Status?"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
DO EXIT
QUIT
+3 IF 'Y
DO EXIT
QUIT
+4 DO EP1^AMHLCD(AMHR)
+5 DO EXIT
+6 QUIT
BV ;
+1 DO ^AMHVD
+2 DO EXIT
+3 QUIT
HS ;EP called from protocol to generate hs
+1 SET DFN=""
+2 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DR,DLAYGO,DIADD
+3 IF Y<0
WRITE !,"No Patient Selected."
QUIT
+4 SET DFN=+Y
+5 SET Y=DFN
DO ^AUPNPAT
+6 IF $GET(AUPNDOD)]""
WRITE !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!!
HANG 2
+7 DO GETTYPE
+8 IF '$GET(APCHSTYP)
DO EN^XBVK("APCH")
QUIT
+9 SET APCHSPAT=DFN
+10 SET %="PCC Health Summary for "_$PIECE(^DPT(APCHSPAT,0),U)
+11 DO VIEWR^XBLM("EN^APCHS",%)
+12 DO EN^XBVK("APCH")
KILL AMCHDAYS,AMCHDOB,%
+13 DO EXIT
+14 QUIT
GETTYPE ;
+1 IF $GET(^AMHSITE(DUZ(2),0))=""
DO DEFAULT
QUIT
+2 SET APCHSTYP=$PIECE(^AMHSITE(DUZ(2),0),U,4)
IF APCHSTYP=""
DO DEFAULT
QUIT
+3 IF '$DATA(^APCHSCTL(APCHSTYP))
WRITE !,"Error in Site Parameter File!",$CHAR(7),$CHAR(7)
SET APCHSTYP=""
QUIT
+4 QUIT
DEFAULT ;
+1 SET APCHSTYP=""
+2 SET X="BEHAVIORAL HEALTH"
SET DIC(0)=""
SET DIC="^APCHSCTL("
DO ^DIC
KILL DIC,DA
+3 IF Y=-1
WRITE !!,"PCC MENTAL HEALTH HEALTH SUMMARY TYPE IS MISSING!! NOTIFY YOUR SUPERVISOR OR SITE MANAGER.",!!
QUIT
+4 SET APCHSTYP=+Y
+5 QUIT
ADDDP ;EP called from protocol to open a new case
+1 DO FULL^VALM1
+2 IF $DATA(IOF)
WRITE @IOF
+3 SET AMHPAT=""
+4 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DR,DLAYGO,DIADD
+5 IF Y<0
WRITE !,"No Patient Selected."
QUIT
+6 SET AMHPAT=+Y
+7 IF '$DATA(^AMHPATR(AMHPAT))
SET DIC="^AMHPATR("
SET DIC(0)="L"
SET DLAYGO=9002011.55
SET X="`"_AMHPAT
DO ^DIC
IF Y=-1
DO ^XBFMK
KILL DLAYGO,DIADD
WRITE !!,"FAILED TO ADD PATIENT TO MHSS PATIENT DATA FILE"
QUIT
+8 SET DA=AMHPAT
SET DDSFILE=9002011.55
SET DR="[AMH PATIENT RELATED DATA]"
DO ^DDS
+9 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
SET AMHQUIT=1
KILL DIMSG
QUIT
+10 DO EXIT
+11 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL AMHX,AMHCASE,AMHPC,AMHR1,AMHPAT,DFN
+2 DO TERM^VALM0
+3 SET VALMBCK="R"
+4 DO GATHER
+5 SET VALMCNT=AMHLINE
+6 DO HDR
+7 KILL X,Y,Z,I
+8 QUIT
EOJ ;
+1 DO EN^XBVK("AMH")
+2 KILL DFN
+3 KILL DDSFILE,DIPGM,Y
+4 KILL X,Y,%,DR,DDS,DA,DIC
+5 KILL AMHCASE,AMHX,AMHD,AMHRCNT,AMHLINE,AMHCDATE
+6 IF $DATA(VALMWD)
DO CLEAR^VALM1
+7 KILL VALM,VALMHDR,VALMKEY,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMLST,VALMVAR,VALMLFT,VALMBCK,VALMCC,VALMAR,VALMBG,VALMCAP,VALMCOFF,VALMCNT,VALMCON,BALMON,VALMEVL,VALMIOXY
+8 DO KILL^AUPNPAT
+9 QUIT
+10 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
AV ;EP add visit
+1 DO FULL^VALM1
+2 DO GETPAT^AMHLEA
+3 IF 'AMHPAT
WRITE !,"NO Patient selected!",!
DO PAUSE^AMHLEA
DO EXIT
QUIT
+4 SET DFN=AMHPAT
+5 SET AMHDPEEP=AMHPROV
+6 DO CONTACT^AMHLEP1(AMHPAT,1)
+7 SET AMHPROV=AMHDPEEP
+8 DO PAUSE^AMHLEA
+9 DO EXIT
+10 QUIT
