Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AMHVRL

AMHVRL.m

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