AMHVRL ; IHS/CMI/LAB - VIEW PT RECORD LT ;
;;4.0;IHS BEHAVIORAL HEALTH;**4**;JUN 18, 2010;Build 28
;
;
;This routine calls a list template to view a patient's record.
;The first screen displayed is the patient's health summary.
;S DIR(0)="Y",DIR("A")="Do you want to display the health summary",DIR("B")="N" KILL DA D ^DIR KILL DIR
;I $D(DIRUT) D EXIT Q
;S AMHVRLHS=Y
S AMHVRLHS=0
;
I '$$PKGCK^AMHVU("APCHS","PCC HEALTH SUMMARY") D D EXIT Q
. D MSG^AMHVU("**HEALTH SUMMARY SOFTWARE NOT INSTALLED**",2,1,1)
;
I '$G(AMHVRLHS) D D EXIT Q
.K DFN K ^TMP("AMHVR",$J)
.F D GETPAT Q:$G(DFN)<1 D
..S (AMHVSAV,AMHPAT)=DFN
..D EN1,FULL^VALM1,EXIT
..Q
.Q
K DFN K ^TMP("AMHVR",$J)
F D GETPAT Q:$G(DFN)<1 D
. NEW AMHPAT,AMHTYP,AMHTAT,AMHMTY,AMCHDAYS,AMCHDOB,AMHVSAV
. D GETHSTYP I '$G(AMHTYP) D EXIT Q
. S AMHPAT=DFN,AMHVSAV=DFN
. D EN,FULL^VALM1,EXIT
;
EOJ ; -- end of job
D LMKILL^AMHVU
Q
;
HAVEPAT ;EP; -- entry point when patient already known
NEW AMHPAT,AMHTYP,AMHTAT,AMHMTY,AMCHDAYS,AMCHDOB,AMHVSAV
D GETHSTYP I '$G(AMHTYP) D EXIT Q
S AMHPAT=DFN,AMHVSAV=DFN
D EN,FULL^VALM1,EXIT
Q
;
EN1 ;EP
S VALMCC=1 ;1=screen mode, 0=scrolling mode
D TERM^VALM0
D EN^VALM("AMHV NO HS VIEW")
D CLEAR^VALM1
Q
;
EN ;EP; -- main entry point for list template AMHV HS VIEW
S VALMCC=1 ;1=screen mode, 0=scrolling mode
D TERM^VALM0
D EN^VALM("AMHV HS VIEW")
D CLEAR^VALM1
Q
;
HDR ;EP; -- header code
S VALMSG=$$VALMSG^AMHVU
Q
;
HDR1 ;EP - no hs view
S VALMSG=" Select the appropriate action Q for QUIT"
Q
INIT1 ;EP - no hs view
K ^TMP("AMHVR",$J) S AMHC=8
S ^TMP("AMHVR",$J,1,0)="Patient: "_$P(^DPT(DFN,0),U)_" HRN: "_$$HRN^AUPNPAT(DFN,DUZ(2))
S ^TMP("AMHVR",$J,2,0)=" "_$$VAL^XBDIQ1(2,DFN,.02)_" DOB: "_$$FMTE^XLFDT($P(^DPT(DFN,0),U,3))_" AGE: "_$$AGE^AUPNPAT(DFN,DT,"E")_" SSN: "_$$SSN^AMHUTIL(DFN)
S ^TMP("AMHVR",$J,3,0)=IORVON_"Designated Providers:"_IORVOFF
S ^TMP("AMHVR",$J,4,0)=" Mental Health: "_$E($$VAL^XBDIQ1(9002011.55,DFN,.02),1,22),$E(^TMP("AMHVR",$J,4,0),40)="Social Services: "_$E($$VAL^XBDIQ1(9002011.55,DFN,.03),1,22)
;S ^TMP("AMHVR",$J,4,0)="Designated Social Services Provider: "_$$VAL^XBDIQ1(9002011.55,DFN,.03)
;S ^TMP("AMHVR",$J,5,0)=" A/SA/CD: "_$E($$VAL^XBDIQ1(9002011.55,DFN,.04)),1,22)
S ^TMP("AMHVR",$J,5,0)=" A/SA: "_$E($$VAL^XBDIQ1(9002011.55,DFN,.04),1,22),$E(^TMP("AMHVR",$J,5,0),40)=" Other: "_$E($$VAL^XBDIQ1(9002011.55,DFN,.12),1,22)
;S ^TMP("AMHVR",$J,6,0)=" Designated OTHER Provider: "_$$VAL^XBDIQ1(9002011.55,DFN,.12)
S ^TMP("AMHVR",$J,6,0)=" Other (2): "_$E($$VAL^XBDIQ1(9002011.55,DFN,.13),1,22),$E(^TMP("AMHVR",$J,6,0),40)=" Primary Care: "_$E($$VAL^XBDIQ1(9000001,DFN,.14),1,22)
;S ^TMP("AMHVR",$J,7,0)=" Designated OTHER (2) Provider: "_$$VAL^XBDIQ1(9002011.55,DFN,.13)
;S ^TMP("AMHVR",$J,8,0)=" Primary Care Provider: "_$$VAL^XBDIQ1(9000001,DFN,.14)
S ^TMP("AMHVR",$J,7,0)=""
S R=$$LVD^AMHDPEE(DFN,"I")
I 'R S ^TMP("AMHVR",$J,8,0)="No BH Visits on File" S AMHC=AMHC+1
I R D
.S ^TMP("AMHVR",$J,8,0)="Last Visit (excl no shows): "_$$FMTE^XLFDT($P($P(^AMHREC(R,0),U),"."))_" "_$$PPNAME^AMHUTIL(R)_" "
.NEW D S D=0 F S D=$O(^AMHRPRO("AD",R,D)) Q:D'=+D D
..S AMHC=AMHC+1 S ^TMP("AMHVR",$J,AMHC,0)=" "_$$VAL^XBDIQ1(9002011.01,D,.01),$E(^TMP("AMHVR",$J,AMHC,0),18)=$$VAL^XBDIQ1(9002011.01,D,.04)
..Q
.Q
AXV ;
;K AMHAX5 S AMHCNT=0
;S AMHSIVD=0 F S AMHSIVD=$O(^AMHREC("AE",DFN,AMHSIVD)) Q:AMHSIVD=""!(AMHCNT>6) D
;.S AMHX=0 F S AMHX=$O(^AMHREC("AE",DFN,AMHSIVD,AMHX)) Q:AMHX'=+AMHX D
;..Q:$P($G(^AMHREC(AMHX,0)),U,14)=""
;..I $$ALLOWVI^AMHUTIL(DUZ,AMHX) S AMHCNT=AMHCNT+1,AMHAX5(AMHCNT)=(9999999-$P(AMHSIVD,"."))_U_$P(^AMHREC(AMHX,0),U,14)
;..Q
;.Q
;I $D(AMHAX5) D
;.S AMHC=AMHC+1,^TMP("AMHVR",$J,AMHC,0)="********** LAST 6 AXIS V VALUES RECORDED. (GAF SCORES) **********"
;.S X="",AMHJ=2 F AMHCNT=6:-1:1 I $D(AMHAX5(AMHCNT)) S $E(X,AMHJ)=$$DATE($P(AMHAX5(AMHCNT),U)) S AMHJ=AMHJ+12
;.S AMHC=AMHC+1,^TMP("AMHVR",$J,AMHC,0)=X
;.S X="",AMHJ=6 F AMHCNT=6:-1:1 I $D(AMHAX5(AMHCNT)) S $E(X,AMHJ)=$P(AMHAX5(AMHCNT),U,2) S AMHJ=AMHJ+12
;.S AMHC=AMHC+1 S ^TMP("AMHVR",$J,AMHC,0)=X
;pending appts
PEND ;
S X="Pending Appointments:",AMHC=AMHC+1,^TMP("AMHVR",$J,AMHC,0)=X
S AMHDAT=0,AMHVDT=DT-.01 F S AMHVDT=$O(^DPT(DFN,"S",AMHVDT)) Q:'AMHVDT D ONEVIS Q:$D(AMHQIT)
S VALMCNT=AMHC
Q
;
ONEVIS S AMHN=^DPT(DFN,"S",AMHVDT,0)
Q:"CP"[$E($P(AMHN,U,2)_" ")
I AMHVDT\1'=AMHDAT S Y=AMHVDT\1 S (AMHPVD,AMHDAT)=$$FMTE^XLFDT(Y)
S AMHVT=$E($P(AMHVDT,".",2)_"000",1,4) S:AMHVT>1300 AMHVT=AMHVT-1200 S:$L(AMHVT)=3 AMHVT=" "_AMHVT S:$E(AMHVT)="0" AMHVT=" "_$E(AMHVT,2,4) S AMHVT=$E(AMHVT,1,2)_":"_$E(AMHVT,3,4)
S AMHTST="" F AMHI=3,4,5 S AMHJ=$P(AMHN,U,AMHI) I AMHJ S:AMHTST]"" AMHTST=AMHTST_"," S AMHTST=AMHTST_$P("^^LAB^XRAY^EKG^",U,AMHI)
S AMHCP=+AMHN,AMHCN=$P(^SC(AMHCP,0),U,1)
S AMHTST="",AMHVNT=""
S AMHVN=0 F AMHQ=0:0 S AMHVN=$O(^SC(AMHCP,"S",AMHVDT,1,AMHVN)) Q:'AMHVN I +^(AMHVN,0)=DFN S AMHTST=$P(^(0),U,2),AMHVNT=$P(^(0),U,4) S:AMHTST AMHTST=AMHTST_" min."
F AMHI=3,4,5 S AMHJ=$P(AMHN,U,AMHI) I AMHJ S:AMHTST]"" AMHTST=AMHTST_"," S AMHTST=AMHTST_$P("^^LAB^XRAY^EKG^",U,AMHI)
L1 ;
S X="",$E(X,2)=AMHDAT,$E(X,15)=AMHVT,$E(X,22)=AMHCN I AMHTST]"" S X=X_" ("_AMHTST_")"
S:$P(AMHN,U,2)["N" X=X_" *** DNKA ***"
S AMHC=AMHC+1,^TMP("AMHVR",$J,AMHC,0)=X
I AMHVNT]"" S AMHC=AMHC+1,^TMP("AMHVR",$J,AMHC,0)=AMHVNT
Q
INIT ;EP; -- init variables and list array
K ^TMP("AMHVR",$J)
D GUIR^XBLM("EN^APCHS","^TMP(""AMHVR"",$J,")
S X=0 F S X=$O(^TMP("AMHVR",$J,X)) Q:'X D
. S VALMCNT=X
. S ^TMP("AMHVR",$J,X,0)=^TMP("AMHVR",$J,X)
S VALMSG=$$VALMSG^AMHVU
Q
;
HELP ;EP; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ;EP; -- exit code
K ^TMP("AMHVR",$J) K DFN
D EN^XBVK("AMH")
D KILL^AUPNPAT
Q
;
EXPND ;EP; -- expand code
Q
;
PAUSE ;EP -- end of action pause
D RETURN^AMHVU Q
;
RESET ;EP -- update partition for return to list manager
I $D(VALMQUIT) S VALMBCK="Q" Q
D TERM^VALM0 S VALMBCK="R"
I '$G(AMHVRLHS) D INIT1,HDR1 Q
D MSG^AMHVU("Updating Health Summary Display. Please Wait...",1,0,0)
D INIT,HDR Q
;
RESET2 ;EP -- update partition without recreating display array
I $D(VALMQUIT) S VALMBCK="Q" Q
I '$G(AMHVRLHS) D TERM^VALM0 S VALMBCK="R" D HDR1 Q
D TERM^VALM0 S VALMBCK="R" D HDR Q
;
GETPAT ;EP -- ask user to select patient
K DIC,DFN,AMHPAT S DIC=9000001,DIC(0)="AEMQZ" D ^DIC I Y>0 S (AMHPAT,DFN)=+Y
Q:Y=-1
I $G(AUPNDOD)]"" W !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!! H 2 D
.W !?25,"Ok" S %=1 D YN^DICN I %'=1 S AMHPAT="",DFN="" Q
I DFN,'$$ALLOWP^AMHUTIL(DUZ,DFN) D NALLOWP^AMHUTIL G GETPAT
W !?25,"Ok" S %=1 D YN^DICN I %'=1 S AMHPAT="",DFN="" G GETPAT
Q
;
GETHSTYP ;EP -- ask user for health summary type
NEW DIC,DR,DD,X
S DIC="^APCHSCTL(",DIC(0)="AEMQ"
S X="" I DUZ(2),$D(^APCCCTRL(DUZ(2),0))#2 S X=$P(^(0),U,3)
I $D(^DISV(DUZ,"^APCHSCTL(")) D
. S Y=^DISV(DUZ,"^APCHSCTL(") I $D(^APCHSCTL(Y,0)) S X=$P(^(0),U,1)
S:X="" X="ADULT REGULAR" S DIC("B")=X
D ^DIC K DIC Q:Y<1 S APCHSTYP=+Y
Q
LV(P) ;
I '$G(P) Q ""
NEW D,V
S D=$O(^AMHREC("AE",P,0))
I 'D Q ""
S V=$O(^AMHREC("AE",P,D,0))
Q V
FS ;EP -called from protcol to display face sheet
D FULL^VALM1
S AMHHDR="Demographic Face Sheet For "_$P(^DPT(DFN,0),U)
D VIEWR^XBLM("START^AGFACE",AMHHDR)
K AGOPT,AGDENT,AGMVDF,AMHHDR
D RESET
Q
HSDISP ;EP
S AMHPATH=$G(DFN),AMHPAT=AMHPATH
D EN^AMHDPP
S (DFN,AMHPAT)=AMHPATH
D RESET
Q
SR ;EP
S AMHPATH=$G(DFN),AMHPAT=AMHPATH
NEW AMHPATH D EP^AMHPST(DFN)
;S (DFN,AMHPAT)=AMHPATH
I '$G(DFN) W !!,"dfn missing"
D RESET
Q
DATE(D) ;EP
I $G(D)="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))
AMHVRL ; IHS/CMI/LAB - VIEW PT RECORD LT ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**4**;JUN 18, 2010;Build 28
+2 ;
+3 ;
+4 ;This routine calls a list template to view a patient's record.
+5 ;The first screen displayed is the patient's health summary.
+6 ;S DIR(0)="Y",DIR("A")="Do you want to display the health summary",DIR("B")="N" KILL DA D ^DIR KILL DIR
+7 ;I $D(DIRUT) D EXIT Q
+8 ;S AMHVRLHS=Y
+9 SET AMHVRLHS=0
+10 ;
+11 IF '$$PKGCK^AMHVU("APCHS","PCC HEALTH SUMMARY")
Begin DoDot:1
+12 DO MSG^AMHVU("**HEALTH SUMMARY SOFTWARE NOT INSTALLED**",2,1,1)
End DoDot:1
DO EXIT
QUIT
+13 ;
+14 IF '$GET(AMHVRLHS)
Begin DoDot:1
+15 KILL DFN
KILL ^TMP("AMHVR",$JOB)
+16 FOR
DO GETPAT
IF $GET(DFN)<1
QUIT
Begin DoDot:2
+17 SET (AMHVSAV,AMHPAT)=DFN
+18 DO EN1
DO FULL^VALM1
DO EXIT
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
DO EXIT
QUIT
+21 KILL DFN
KILL ^TMP("AMHVR",$JOB)
+22 FOR
DO GETPAT
IF $GET(DFN)<1
QUIT
Begin DoDot:1
+23 NEW AMHPAT,AMHTYP,AMHTAT,AMHMTY,AMCHDAYS,AMCHDOB,AMHVSAV
+24 DO GETHSTYP
IF '$GET(AMHTYP)
DO EXIT
QUIT
+25 SET AMHPAT=DFN
SET AMHVSAV=DFN
+26 DO EN
DO FULL^VALM1
DO EXIT
End DoDot:1
+27 ;
EOJ ; -- end of job
+1 DO LMKILL^AMHVU
+2 QUIT
+3 ;
HAVEPAT ;EP; -- entry point when patient already known
+1 NEW AMHPAT,AMHTYP,AMHTAT,AMHMTY,AMCHDAYS,AMCHDOB,AMHVSAV
+2 DO GETHSTYP
IF '$GET(AMHTYP)
DO EXIT
QUIT
+3 SET AMHPAT=DFN
SET AMHVSAV=DFN
+4 DO EN
DO FULL^VALM1
DO EXIT
+5 QUIT
+6 ;
EN1 ;EP
+1 ;1=screen mode, 0=scrolling mode
SET VALMCC=1
+2 DO TERM^VALM0
+3 DO EN^VALM("AMHV NO HS VIEW")
+4 DO CLEAR^VALM1
+5 QUIT
+6 ;
EN ;EP; -- main entry point for list template AMHV HS VIEW
+1 ;1=screen mode, 0=scrolling mode
SET VALMCC=1
+2 DO TERM^VALM0
+3 DO EN^VALM("AMHV HS VIEW")
+4 DO CLEAR^VALM1
+5 QUIT
+6 ;
HDR ;EP; -- header code
+1 SET VALMSG=$$VALMSG^AMHVU
+2 QUIT
+3 ;
HDR1 ;EP - no hs view
+1 SET VALMSG=" Select the appropriate action Q for QUIT"
+2 QUIT
INIT1 ;EP - no hs view
+1 KILL ^TMP("AMHVR",$JOB)
SET AMHC=8
+2 SET ^TMP("AMHVR",$JOB,1,0)="Patient: "_$PIECE(^DPT(DFN,0),U)_" HRN: "_$$HRN^AUPNPAT(DFN,DUZ(2))
+3 SET ^TMP("AMHVR",$JOB,2,0)=" "_$$VAL^XBDIQ1(2,DFN,.02)_" DOB: "_$$FMTE^XLFDT($PIECE(^DPT(DFN,0),U,3))_" AGE: "_$$AGE^AUPNPAT(DFN,DT,"E")_" SSN: "_$$SSN^AMHUTIL(DFN)
+4 SET ^TMP("AMHVR",$JOB,3,0)=IORVON_"Designated Providers:"_IORVOFF
+5 SET ^TMP("AMHVR",$JOB,4,0)=" Mental Health: "_$EXTRACT($$VAL^XBDIQ1(9002011.55,DFN,.02),1,22)
SET $EXTRACT(^TMP("AMHVR",$JOB,4,0),40)="Social Services: "_$EXTRACT($$VAL^XBDIQ1(9002011.55,DFN,.03),1,22)
+6 ;S ^TMP("AMHVR",$J,4,0)="Designated Social Services Provider: "_$$VAL^XBDIQ1(9002011.55,DFN,.03)
+7 ;S ^TMP("AMHVR",$J,5,0)=" A/SA/CD: "_$E($$VAL^XBDIQ1(9002011.55,DFN,.04)),1,22)
+8 SET ^TMP("AMHVR",$JOB,5,0)=" A/SA: "_$EXTRACT($$VAL^XBDIQ1(9002011.55,DFN,.04),1,22)
SET $EXTRACT(^TMP("AMHVR",$JOB,5,0),40)=" Other: "_$EXTRACT($$VAL^XBDIQ1(9002011.55,DFN,.12),1,22)
+9 ;S ^TMP("AMHVR",$J,6,0)=" Designated OTHER Provider: "_$$VAL^XBDIQ1(9002011.55,DFN,.12)
+10 SET ^TMP("AMHVR",$JOB,6,0)=" Other (2): "_$EXTRACT($$VAL^XBDIQ1(9002011.55,DFN,.13),1,22)
SET $EXTRACT(^TMP("AMHVR",$JOB,6,0),40)=" Primary Care: "_$EXTRACT($$VAL^XBDIQ1(9000001,DFN,.14),1,22)
+11 ;S ^TMP("AMHVR",$J,7,0)=" Designated OTHER (2) Provider: "_$$VAL^XBDIQ1(9002011.55,DFN,.13)
+12 ;S ^TMP("AMHVR",$J,8,0)=" Primary Care Provider: "_$$VAL^XBDIQ1(9000001,DFN,.14)
+13 SET ^TMP("AMHVR",$JOB,7,0)=""
+14 SET R=$$LVD^AMHDPEE(DFN,"I")
+15 IF 'R
SET ^TMP("AMHVR",$JOB,8,0)="No BH Visits on File"
SET AMHC=AMHC+1
+16 IF R
Begin DoDot:1
+17 SET ^TMP("AMHVR",$JOB,8,0)="Last Visit (excl no shows): "_$$FMTE^XLFDT($PIECE($PIECE(^AMHREC(R,0),U),"."))_" "_$$PPNAME^AMHUTIL(R)_" "
+18 NEW D
SET D=0
FOR
SET D=$ORDER(^AMHRPRO("AD",R,D))
IF D'=+D
QUIT
Begin DoDot:2
+19 SET AMHC=AMHC+1
SET ^TMP("AMHVR",$JOB,AMHC,0)=" "_$$VAL^XBDIQ1(9002011.01,D,.01)
SET $EXTRACT(^TMP("AMHVR",$JOB,AMHC,0),18)=$$VAL^XBDIQ1(9002011.01,D,.04)
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
AXV ;
+1 ;K AMHAX5 S AMHCNT=0
+2 ;S AMHSIVD=0 F S AMHSIVD=$O(^AMHREC("AE",DFN,AMHSIVD)) Q:AMHSIVD=""!(AMHCNT>6) D
+3 ;.S AMHX=0 F S AMHX=$O(^AMHREC("AE",DFN,AMHSIVD,AMHX)) Q:AMHX'=+AMHX D
+4 ;..Q:$P($G(^AMHREC(AMHX,0)),U,14)=""
+5 ;..I $$ALLOWVI^AMHUTIL(DUZ,AMHX) S AMHCNT=AMHCNT+1,AMHAX5(AMHCNT)=(9999999-$P(AMHSIVD,"."))_U_$P(^AMHREC(AMHX,0),U,14)
+6 ;..Q
+7 ;.Q
+8 ;I $D(AMHAX5) D
+9 ;.S AMHC=AMHC+1,^TMP("AMHVR",$J,AMHC,0)="********** LAST 6 AXIS V VALUES RECORDED. (GAF SCORES) **********"
+10 ;.S X="",AMHJ=2 F AMHCNT=6:-1:1 I $D(AMHAX5(AMHCNT)) S $E(X,AMHJ)=$$DATE($P(AMHAX5(AMHCNT),U)) S AMHJ=AMHJ+12
+11 ;.S AMHC=AMHC+1,^TMP("AMHVR",$J,AMHC,0)=X
+12 ;.S X="",AMHJ=6 F AMHCNT=6:-1:1 I $D(AMHAX5(AMHCNT)) S $E(X,AMHJ)=$P(AMHAX5(AMHCNT),U,2) S AMHJ=AMHJ+12
+13 ;.S AMHC=AMHC+1 S ^TMP("AMHVR",$J,AMHC,0)=X
+14 ;pending appts
PEND ;
+1 SET X="Pending Appointments:"
SET AMHC=AMHC+1
SET ^TMP("AMHVR",$JOB,AMHC,0)=X
+2 SET AMHDAT=0
SET AMHVDT=DT-.01
FOR
SET AMHVDT=$ORDER(^DPT(DFN,"S",AMHVDT))
IF 'AMHVDT
QUIT
DO ONEVIS
IF $DATA(AMHQIT)
QUIT
+3 SET VALMCNT=AMHC
+4 QUIT
+5 ;
ONEVIS SET AMHN=^DPT(DFN,"S",AMHVDT,0)
+1 IF "CP"[$EXTRACT($PIECE(AMHN,U,2)_" ")
QUIT
+2 IF AMHVDT\1'=AMHDAT
SET Y=AMHVDT\1
SET (AMHPVD,AMHDAT)=$$FMTE^XLFDT(Y)
+3 SET AMHVT=$EXTRACT($PIECE(AMHVDT,".",2)_"000",1,4)
IF AMHVT>1300
SET AMHVT=AMHVT-1200
IF $LENGTH(AMHVT)=3
SET AMHVT=" "_AMHVT
IF $EXTRACT(AMHVT)="0"
SET AMHVT=" "_$EXTRACT(AMHVT,2,4)
SET AMHVT=$EXTRACT(AMHVT,1,2)_":"_$EXTRACT(AMHVT,3,4)
+4 SET AMHTST=""
FOR AMHI=3,4,5
SET AMHJ=$PIECE(AMHN,U,AMHI)
IF AMHJ
IF AMHTST]""
SET AMHTST=AMHTST_","
SET AMHTST=AMHTST_$PIECE("^^LAB^XRAY^EKG^",U,AMHI)
+5 SET AMHCP=+AMHN
SET AMHCN=$PIECE(^SC(AMHCP,0),U,1)
+6 SET AMHTST=""
SET AMHVNT=""
+7 SET AMHVN=0
FOR AMHQ=0:0
SET AMHVN=$ORDER(^SC(AMHCP,"S",AMHVDT,1,AMHVN))
IF 'AMHVN
QUIT
IF +^(AMHVN,0)=DFN
SET AMHTST=$PIECE(^(0),U,2)
SET AMHVNT=$PIECE(^(0),U,4)
IF AMHTST
SET AMHTST=AMHTST_" min."
+8 FOR AMHI=3,4,5
SET AMHJ=$PIECE(AMHN,U,AMHI)
IF AMHJ
IF AMHTST]""
SET AMHTST=AMHTST_","
SET AMHTST=AMHTST_$PIECE("^^LAB^XRAY^EKG^",U,AMHI)
L1 ;
+1 SET X=""
SET $EXTRACT(X,2)=AMHDAT
SET $EXTRACT(X,15)=AMHVT
SET $EXTRACT(X,22)=AMHCN
IF AMHTST]""
SET X=X_" ("_AMHTST_")"
+2 IF $PIECE(AMHN,U,2)["N"
SET X=X_" *** DNKA ***"
+3 SET AMHC=AMHC+1
SET ^TMP("AMHVR",$JOB,AMHC,0)=X
+4 IF AMHVNT]""
SET AMHC=AMHC+1
SET ^TMP("AMHVR",$JOB,AMHC,0)=AMHVNT
+5 QUIT
INIT ;EP; -- init variables and list array
+1 KILL ^TMP("AMHVR",$JOB)
+2 DO GUIR^XBLM("EN^APCHS","^TMP(""AMHVR"",$J,")
+3 SET X=0
FOR
SET X=$ORDER(^TMP("AMHVR",$JOB,X))
IF 'X
QUIT
Begin DoDot:1
+4 SET VALMCNT=X
+5 SET ^TMP("AMHVR",$JOB,X,0)=^TMP("AMHVR",$JOB,X)
End DoDot:1
+6 SET VALMSG=$$VALMSG^AMHVU
+7 QUIT
+8 ;
HELP ;EP; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ;EP; -- exit code
+1 KILL ^TMP("AMHVR",$JOB)
KILL DFN
+2 DO EN^XBVK("AMH")
+3 DO KILL^AUPNPAT
+4 QUIT
+5 ;
EXPND ;EP; -- expand code
+1 QUIT
+2 ;
PAUSE ;EP -- end of action pause
+1 DO RETURN^AMHVU
QUIT
+2 ;
RESET ;EP -- update partition for return to list manager
+1 IF $DATA(VALMQUIT)
SET VALMBCK="Q"
QUIT
+2 DO TERM^VALM0
SET VALMBCK="R"
+3 IF '$GET(AMHVRLHS)
DO INIT1
DO HDR1
QUIT
+4 DO MSG^AMHVU("Updating Health Summary Display. Please Wait...",1,0,0)
+5 DO INIT
DO HDR
QUIT
+6 ;
RESET2 ;EP -- update partition without recreating display array
+1 IF $DATA(VALMQUIT)
SET VALMBCK="Q"
QUIT
+2 IF '$GET(AMHVRLHS)
DO TERM^VALM0
SET VALMBCK="R"
DO HDR1
QUIT
+3 DO TERM^VALM0
SET VALMBCK="R"
DO HDR
QUIT
+4 ;
GETPAT ;EP -- ask user to select patient
+1 KILL DIC,DFN,AMHPAT
SET DIC=9000001
SET DIC(0)="AEMQZ"
DO ^DIC
IF Y>0
SET (AMHPAT,DFN)=+Y
+2 IF Y=-1
QUIT
+3 IF $GET(AUPNDOD)]""
WRITE !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!!
HANG 2
Begin DoDot:1
+4 WRITE !?25,"Ok"
SET %=1
DO YN^DICN
IF %'=1
SET AMHPAT=""
SET DFN=""
QUIT
End DoDot:1
+5 IF DFN
IF '$$ALLOWP^AMHUTIL(DUZ,DFN)
DO NALLOWP^AMHUTIL
GOTO GETPAT
+6 WRITE !?25,"Ok"
SET %=1
DO YN^DICN
IF %'=1
SET AMHPAT=""
SET DFN=""
GOTO GETPAT
+7 QUIT
+8 ;
GETHSTYP ;EP -- ask user for health summary type
+1 NEW DIC,DR,DD,X
+2 SET DIC="^APCHSCTL("
SET DIC(0)="AEMQ"
+3 SET X=""
IF DUZ(2)
IF $DATA(^APCCCTRL(DUZ(2),0))#2
SET X=$PIECE(^(0),U,3)
+4 IF $DATA(^DISV(DUZ,"^APCHSCTL("))
Begin DoDot:1
+5 SET Y=^DISV(DUZ,"^APCHSCTL(")
IF $DATA(^APCHSCTL(Y,0))
SET X=$PIECE(^(0),U,1)
End DoDot:1
+6 IF X=""
SET X="ADULT REGULAR"
SET DIC("B")=X
+7 DO ^DIC
KILL DIC
IF Y<1
QUIT
SET APCHSTYP=+Y
+8 QUIT
LV(P) ;
+1 IF '$GET(P)
QUIT ""
+2 NEW D,V
+3 SET D=$ORDER(^AMHREC("AE",P,0))
+4 IF 'D
QUIT ""
+5 SET V=$ORDER(^AMHREC("AE",P,D,0))
+6 QUIT V
FS ;EP -called from protcol to display face sheet
+1 DO FULL^VALM1
+2 SET AMHHDR="Demographic Face Sheet For "_$PIECE(^DPT(DFN,0),U)
+3 DO VIEWR^XBLM("START^AGFACE",AMHHDR)
+4 KILL AGOPT,AGDENT,AGMVDF,AMHHDR
+5 DO RESET
+6 QUIT
HSDISP ;EP
+1 SET AMHPATH=$GET(DFN)
SET AMHPAT=AMHPATH
+2 DO EN^AMHDPP
+3 SET (DFN,AMHPAT)=AMHPATH
+4 DO RESET
+5 QUIT
SR ;EP
+1 SET AMHPATH=$GET(DFN)
SET AMHPAT=AMHPATH
+2 NEW AMHPATH
DO EP^AMHPST(DFN)
+3 ;S (DFN,AMHPAT)=AMHPATH
+4 IF '$GET(DFN)
WRITE !!,"dfn missing"
+5 DO RESET
+6 QUIT
DATE(D) ;EP
+1 IF $GET(D)=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+$EXTRACT(D,1,3))
