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

AMHHS.m

Go to the documentation of this file. 
  1. AMHHS ; IHS/CMI/LAB - BH HEALTH SUMMARY COMPONENT 03 Jun 2009 12:08 PM ;
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;**1,5,6,8**;JUN 02, 2010;Build 7
  1.  ;
  1.  ;
  1. MH ;EP called from health summary
  1.  NEW AMHPATH
  1.  X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK
  1.  I $P($G(^AMHPATR(APCHSPAT,0)),U,9)]"" W ?23,"Patient Flag: ",?38,$P(^AMHPATR(APCHSPAT,0),U,9),!
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  I $P($G(^AMHPATR(APCHSPAT,0)),U,11)]"" W ?21,"Flag Narrative: ",?38,$P(^AMHPATR(APCHSPAT,0),U,11),!
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  I $P($G(^AMHPATR(APCHSPAT,0)),U,2)]"" W ?2,"Designated Mental Health Provider: ",?38,$P(^VA(200,$P(^AMHPATR(APCHSPAT,0),U,2),0),U),!
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  I $P($G(^AMHPATR(APCHSPAT,0)),U,3)]"" W "Designated Social Services Provider: ",?38,$P(^VA(200,$P(^AMHPATR(APCHSPAT,0),U,3),0),U),!
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  I $P($G(^AMHPATR(APCHSPAT,0)),U,4)]"" W ?10,"CD Designated Provider: ",?38,$P(^VA(200,$P(^AMHPATR(APCHSPAT,0),U,4),0),U),!
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  I $P($G(^AMHPATR(APCHSPAT,0)),U,12)]"" W ?10,"Other Designated Provider: ",?38,$P(^VA(200,$P(^AMHPATR(APCHSPAT,0),U,12),0),U),!
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  I $P($G(^AMHPATR(APCHSPAT,0)),U,13)]"" W ?10,"Other (2) Designated Provider: ",?38,$P(^AMHPATR(APCHSPAT,0),U,13),!
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  ;output personal history
  1.  I $D(^AMHPPHX("AC",APCHSPAT)) D
  1.  .X APCHSCKP Q:$D(APCHSQIT)  W !,"** Personal History of:",!
  1.  .S AMHSX=0 F  S AMHSX=$O(^AMHPPHX("AC",APCHSPAT,AMHSX)) Q:AMHSX'=+AMHSX  D
  1.  ..S Y=$P(^AMHPPHX(AMHSX,0),U,3) X APCHSCVD S AMHSDAT=Y
  1.  ..W !?5,$P(^AMHTPHF($P(^AMHPPHX(AMHSX,0),U),0),U),?30,"(noted: ",AMHSDAT,")"
  1.  ..Q
  1.  .W ! K AMHSX
  1.  .Q
  1. CASE ;output last 3 cases
  1.  K AMHL S D=0,C=0 F  S D=$O(^AMHPCASE("AA",APCHSPAT,D)) Q:D'=+D!(C>2)  D
  1.  .S AMHL=0 F  S AMHL=$O(^AMHPCASE("AA",APCHSPAT,D,AMHL)) Q:AMHL'=+AMHL!(C>2)  D
  1.  ..Q:'$$ALLOWCD^AMHLCD(DUZ,AMHL)
  1.  ..S C=C+1
  1.  ..S AMHL(C)=AMHL
  1.  ..Q
  1.  .Q
  1. CASEOUT ;display last 3 cases found
  1.  I $D(AMHL(1)) D
  1.  .X APCHSCKP Q:$D(APCHSQIT)
  1.  .S K="21;41;61"
  1.  .W ?4,"Case Open Date:"
  1.  .F I=1:1:3 Q:'$D(AMHL(I))  S J=$P(K,";",I) W ?J,$$FMTE^XLFDT($P(^AMHPCASE(AMHL(I),0),U),"2E")
  1.  .X APCHSCKP Q:$D(APCHSQIT)
  1.  .W !?3,"Case Admit Date:"
  1.  .F I=1:1:3 Q:'$D(AMHL(I))  I $P(^AMHPCASE(AMHL(I),0),U,4)]"" S J=$P(K,";",I) W ?J,$$FMTE^XLFDT($P(^AMHPCASE(AMHL(I),0),U,4),"2E")
  1.  .X APCHSCKP Q:$D(APCHSQIT)
  1.  .W !?3,"Case Close Date:"
  1.  .F I=1:1:3 Q:'$D(AMHL(I))  I $P(^AMHPCASE(AMHL(I),0),U,5)]"" S J=$P(K,";",I) W ?J,$$FMTE^XLFDT($P(^AMHPCASE(AMHL(I),0),U,5),"2E")
  1.  .X APCHSCKP Q:$D(APCHSQIT)
  1.  .W !?5,"Program Affil:"
  1.  .F I=1:1:3 Q:'$D(AMHL(I))  I $P(^AMHPCASE(AMHL(I),0),U,3)]"" S J=$P(K,";",I) W ?J,$$VAL^XBDIQ1(9002011.58,AMHL(I),.03)
  1.  .X APCHSCKP Q:$D(APCHSQIT)
  1.  .W !?7,"Disposition:"
  1.  .F I=1:1:3 Q:'$D(AMHL(I))  I $P(^AMHPCASE(AMHL(I),0),U,6)]"" S J=$P(K,";",I) W ?J,$$VAL^XBDIQ1(9002011.58,AMHL(I),.06)
  1.  .X APCHSCKP Q:$D(APCHSQIT)
  1.  .W !?2,"Next Review Date:"
  1.  .F I=1:1:3 Q:'$D(AMHL(I))  I $P(^AMHPCASE(AMHL(I),0),U,12)]"" S J=$P(K,";",I) W ?J,$$FMTE^XLFDT($P(^AMHPCASE(AMHL(I),0),U,12),"2E")
  1.  .X APCHSCKP Q:$D(APCHSQIT)
  1.  .W !?10,"Provider:"
  1.  .F I=1:1:3 Q:'$D(AMHL(I))  I $P(^AMHPCASE(AMHL(I),0),U,8)]"" S J=$P(K,";",I) W ?J,$$VAL^XBDIQ1(9002011.58,AMHL(I),.08)
  1.  .X APCHSCKP Q:$D(APCHSQIT)
  1.  .W !?11,"Problem:"
  1.  .F I=1:1:3 Q:'$D(AMHL(I))  I $P(^AMHPCASE(AMHL(I),0),U,9)]"" S J=$P(K,";",I) W ?J,$$VAL^XBDIQ1(9002011.58,AMHL(I),.09)
  1.  K AMHL,C,D,L,K
  1.  D PROB^AMHHS1
  1. AXV ;trend and display last 7 AXIS V values
  1.  K AMHAX5 S AMHCNT=0
  1.  S AMHSIVD=0 F  S AMHSIVD=$O(^AMHREC("AE",APCHSPAT,AMHSIVD)) Q:AMHSIVD=""!($D(APCHSQIT))!(AMHCNT>6)  D
  1.  .S AMHSX=0 F  S AMHSX=$O(^AMHREC("AE",APCHSPAT,AMHSIVD,AMHSX)) Q:AMHSX'=+AMHSX  D
  1.  ..Q:$P($G(^AMHREC(AMHSX,0)),U,14)=""
  1.  ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHSX)
  1.  ..S AMHCNT=AMHCNT+1,AMHAX5(AMHCNT)=(9999999-$P(AMHSIVD,"."))_U_$P(^AMHREC(AMHSX,0),U,14)
  1.  ..Q
  1.  .Q
  1.  I $D(AMHAX5) D  Q:$D(APCHSQIT)
  1.  .X APCHSCKP Q:$D(APCHSQIT)
  1.  .W !!?4,"**********  LAST 6 AXIS V VALUES RECORDED.  (GAF SCORES)  **********",!!
  1.  .S AMHJ=2 F AMHCNT=6:-1:1  I $D(AMHAX5(AMHCNT))  W ?AMHJ,$$DATE($P(AMHAX5(AMHCNT),U)) S AMHJ=AMHJ+12
  1.  .W ! S AMHJ=6 F AMHCNT=6:-1:1 I $D(AMHAX5(AMHCNT)) W ?AMHJ,$P(AMHAX5(AMHCNT),U,2) S AMHJ=AMHJ+12
  1.  .W !
  1. OUTPT ; ********** MH PROBLEM CODES AND DESIGNATED PROVIDER
  1.  ; <SETUP>
  1.  X APCHSCKP Q:$D(APCHSQIT)  S X="********************  BH ENCOUNTERS  ******************** ",AMHS="",$P(AMHS," ",80-1-$L(X)/2)="" W !,AMHS,X,AMHS,!!
  1.  I '$D(^AMHREC("AE",APCHSPAT)) X APCHSCKP Q:$D(APCHSQIT)  W !,"No Behavioral Health Records on File.",! Q
  1.  ; <DISPLAY>
  1.  S AMHSPVD=0
  1.  F AMHSIVD=0:0 S AMHSIVD=$O(^AMHREC("AE",APCHSPAT,AMHSIVD)) Q:AMHSIVD=""!($P(AMHSIVD,".")>APCHSDLM)  D ONEDATE Q:$D(APCHSQIT)  S:(AMHSDAT'=AMHSPVD)&AMHSDTU APCHSNDM=APCHSNDM-AMHSDTU,AMHSPVD=AMHSDAT Q:APCHSNDM=0
  1. PTED ;display all pt ed (last of each)
  1.  I '$D(^AMHREDU("AC",APCHSPAT)) G HF
  1.  X APCHSCKP Q:$D(APCHSQIT)  S X="************  BEHAVIORAL HEALTH PATIENT EDUCATION  ******************** ",AMHS="",$P(AMHS," ",80-1-$L(X)/2)="" W !,AMHS,X,AMHS,!
  1.  K AMHSN S AMHSX=0 F  S AMHSX=$O(^AMHREDU("AC",APCHSPAT,AMHSX)) Q:AMHSX'=+AMHSX!($D(APCHSQIT))  D
  1.  .S X=$P(^AMHREDU(AMHSX,0),U),Y=$P(^AMHREDU(AMHSX,0),U,3) I Y,$D(^AMHREC(Y,0)),$$ALLOWVI^AMHUTIL(DUZ,Y) S Y=$P($P(^AMHREC(Y,0),U),".") I $P($G(AMHSN(X)),U)<Y S AMHSN(X)=Y_U_AMHSX
  1.  K AMHSD S X=0 F  S X=$O(AMHSN(X)) Q:X'=+X  S Y=$P(AMHSN(X),U),Y=9999999-Y,AMHSD(Y,X)=$P(AMHSN(X),U,2)
  1.  S AMHSD=0 F  S AMHSD=$O(AMHSD(AMHSD)) Q:AMHSD'=+AMHSD!($D(APCHSQIT))  D
  1.  .S AMHSX=0 F  S AMHSX=$O(AMHSD(AMHSD,AMHSX)) Q:AMHSX'=+AMHSX!($D(APCHSQIT))  D
  1.  ..X APCHSCKP Q:$D(APCHSQIT)
  1.  ..W !,$$FMTE^XLFDT(9999999-AMHSD),?15,$E($P(^AUTTEDT(AMHSX,0),U),1,30),?47,$$VAL^XBDIQ1(9002011.05,AMHSD(AMHSD,AMHSX),.05)
  1.  ..X APCHSCKP Q:$D(APCHSQIT)
  1.  ..W !?3,"Level of Understanding: ",$$VAL^XBDIQ1(9002011.05,AMHSD(AMHSD,AMHSX),.08),?47,$P(^AMHREDU(AMHSD(AMHSD,AMHSX),0),U,6),$S($P(^AMHREDU(AMHSD(AMHSD,AMHSX),0),U,6)]"":" mins",1:"")
  1.  ..I $P(^AMHREDU(AMHSD(AMHSD,AMHSX),0),U,9)]"" W !?3,"Goal: ",$$VAL^XBDIQ1(9002011.05,AMHSD(AMHSD,AMHSX),.09)
  1.  ..I $P(^AMHREDU(AMHSD(AMHSD,AMHSX),0),U,11)]"" W !?3,"Status: ",$$VAL^XBDIQ1(9002011.05,AMHSD(AMHSD,AMHSX),.11)
  1.  ..I $P($G(^AMHREDU(AMHSD(AMHSD,AMHSX),11)),U)]"" X APCHSCKP Q:$D(APCHSQIT)  W !?3,"Comment: ",$P(^AMHREDU(AMHSD(AMHSD,AMHSX),11),U)
  1.  ..Q
  1.  .Q
  1. HF ;
  1.  I '$D(^AMHRHF("AC",APCHSPAT)) G IPV
  1.  X APCHSCKP Q:$D(APCHSQIT)  S X="************  BEHAVIORAL HEALTH HEALTH FACTORS  ************* ",AMHS="",$P(AMHS," ",80-1-$L(X)/2)="" W !!,AMHS,X,AMHS,!
  1.  K AMHSN S AMHSX=0 F  S AMHSX=$O(^AMHRHF("AC",APCHSPAT,AMHSX)) Q:AMHSX'=+AMHSX!($D(APCHSQIT))  D
  1.  .S X=$P(^AMHRHF(AMHSX,0),U),Y=$P(^AMHRHF(AMHSX,0),U,3) I Y,$D(^AMHREC(Y,0)),$$ALLOWVI^AMHUTIL(DUZ,Y) S Y=$P($P(^AMHREC(Y,0),U),".") I $P($G(AMHSN(X)),U)<Y S AMHSN(X)=Y_U_AMHSX
  1.  K AMHSD S X=0 F  S X=$O(AMHSN(X)) Q:X'=+X  S Y=$P(AMHSN(X),U),Y=9999999-Y,AMHSD(Y,X)=$P(AMHSN(X),U,2)
  1.  S AMHSD=0 F  S AMHSD=$O(AMHSD(AMHSD)) Q:AMHSD'=+AMHSD!($D(APCHSQIT))  D
  1.  .S AMHSX=0 F  S AMHSX=$O(AMHSD(AMHSD,AMHSX)) Q:AMHSX'=+AMHSX!($D(APCHSQIT))  D
  1.  ..X APCHSCKP Q:$D(APCHSQIT)
  1.  ..W !,$$FMTE^XLFDT(9999999-AMHSD),?15,$E($P(^AUTTHF(AMHSX,0),U),1,30)
  1.  ..W ?47,"Quantity: ",$$VAL^XBDIQ1(9002011.08,AMHSD(AMHSD,AMHSX),.08)
  1.  ..I $P($G(^AMHRHF(AMHSD(AMHSD,AMHSX),0)),U,4)]"" X APCHSCKP Q:$D(APCHSQIT)  W !?3,"Level/Severity: ",$P(^AMHRHF(AMHSD(AMHSD,AMHSX),0),U,4)
  1.  ..Q
  1.  .Q
  1. IPV ;
  1.  X APCHSCKP Q:$D(APCHSQIT)  S X="*********  BEHAVIORAL HEALTH Screening Exams ********* ",AMHS="",$P(AMHS," ",80-1-$L(X)/2)="" W !!,AMHS,X,AMHS,!
  1.  F AMHSIVD=0:0 S AMHSIVD=$O(^AMHREC("AE",APCHSPAT,AMHSIVD)) Q:AMHSIVD=""!($P(AMHSIVD,".")>APCHSDLM)!($D(APCHSQIT))  D
  1.  .S AMHSX=0 F  S AMHSX=$O(^AMHREC("AE",APCHSPAT,AMHSIVD,AMHSX)) Q:AMHSX'=+AMHSX  D
  1.  ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHSX)
  1.  ..;I $P($G(^AMHREC(AMHSX,14)),U)="",$P($G(^AMHREC(AMHSX,14)),U,3)="",$P($G(^AMHREC(AMHSX,14)),U,5)="",$P($G(^AMHREC(AMHSX,14)),U,7)="" Q
  1.  ..X APCHSCKP Q:$D(APCHSQIT)
  1.  ..I $P($G(^AMHREC(AMHSX,14)),U)]"" W !,"IPV/DV SCREENING",?24,$$D((9999999-$P(AMHSIVD,"."))),?62,$E($$VAL^XBDIQ1(9002011,AMHSX,1402),1,15)
  1.  ..I $P($G(^AMHREC(AMHSX,14)),U,3)]"" W !,"ALCOHOL SCREENING",?24,$$D((9999999-$P(AMHSIVD,"."))),?33,$$VAL^XBDIQ1(9002011,AMHSX,1403),?62,$E($$VAL^XBDIQ1(9002011,AMHSX,1404),1,15)
  1.  ..I $P($G(^AMHREC(AMHSX,14)),U,5)]"" W !,"DEPRESSION SCREENING ",?24,$$D((9999999-$P(AMHSIVD,"."))),?33,$$VAL^XBDIQ1(9002011,AMHSX,1405),?62,$E($$VAL^XBDIQ1(9002011,AMHSX,1406),1,15)
  1.  ..I $P($G(^AMHREC(AMHSX,14)),U,7)]"" W !,"SUICIDE RISK ASSESSMENT",?24,$$D((9999999-$P(AMHSIVD,"."))),?33,$$VAL^XBDIQ1(9002011,AMHSX,1407),?62,$E($$VAL^XBDIQ1(9002011,AMHSX,1408),1,15)
  1.  ..;I $P($G(^AMHREC(AMHSX,15)),U)]"" X APCHSCKP Q:$D(APCHSQIT)  W !?3,$P(^AMHREC(AMHSX,15),U)
  1. MEASBH ;
  1.  D MEAS
  1. OUTPTX K AMHS,AMHSX,AMHSDAT,AMHL,AMHAX5,AMHCNT,AMHSIVD,AMHIVD,AMHJ,AMHSPVD,AMHSDTU,AMHSN,AMHSD
  1.  K AMHSIVD,AMHSDTU,AMHSVDF,AMHSFAC,AMHSPFN,AMHSMTX,AMHSPVD,AMHSOVT,AMHSNDT,AMHSCLI,AMHSPDN,AMHSICD,AMHSICL,AMHSDAT,AMHSN,AMHSQ,AMHSR,AMHSX,AMHS,AMHTOC
  1.  K AMHSNFL,AMHSNSH,AMHSNAB,AMHSVSC,AMHSFAC,Y
  1.  K Y
  1.  Q
  1. ONEDATE S Y=-AMHSIVD\1+9999999 X APCHSCVD S AMHSDAT=Y S AMHSPFN="",AMHSDTU=0,AMHSNDT=(AMHSDAT'=AMHSPVD)
  1.  S AMHSVDF="" F AMHSQ=0:0 S AMHSVDF=$O(^AMHREC("AE",APCHSPAT,AMHSIVD,AMHSVDF)) Q:AMHSVDF=""  I $$ALLOWVI^AMHUTIL(DUZ,AMHSVDF) S AMHSN=^AMHREC(AMHSVDF,0) D GETSITE,DSPVIS Q:$D(APCHSQIT)
  1.  Q
  1.  ;
  1. GETSITE ;
  1.  S AMHSFAC=$P(AMHSN,U,4) S AMHSFAC=$S(AMHSFAC:$E($P(^AUTTLOC(AMHSFAC,0),U,2),1,8),1:"<missing>")
  1.  I AMHSFAC="" S AMHSFAC=$E($P(^DIC(4,$P(AMHSN,U,4),0),U),1,8)
  1.  S AMHTOC=$P(AMHSN,U,7) I AMHTOC]"" S AMHTOC=$P(^AMHTSET(AMHTOC,0),U,4)
  1.  Q
  1. DSPVIS ;
  1.  S AMHSDTU=1
  1.  I $O(^AMHRPRO("AD",AMHSVDF,""))="" D NOPOV Q
  1.  S AMHSPDN="" F AMHSQ=0:0 S AMHSPDN=$O(^AMHRPRO("AD",AMHSVDF,AMHSPDN)) Q:'AMHSPDN  S AMHSR=^AMHRPRO(AMHSPDN,0) D HASPOV
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  ;I $P(AMHSN,U,13)]"" W ?25,"Axis IV (Stress): ",$P(^AMHTAXIV($P(AMHSN,U,13),0),U,2)," - ",$P(^AMHTAXIV($P(AMHSN,U,13),0),U) W:$P(AMHSN,U,14)="" !
  1.  ;W:$P(AMHSN,U,14)]"" ?50,"Axis V (Function):  ",$P(AMHSN,U,14),!
  1.  I $D(^AMHREC(AMHSVDF,61))!($P(^AMHREC(AMHSVDF,0),U,14)]"") D  Q:$D(APCHSQIT)
  1.  .X APCHSCKP Q:$D(APCHSQIT)
  1.  .W ?27,"AXIS IV:  " S Y=0 F  S Y=$O(^AMHREC(AMHSVDF,61,Y)) Q:Y'=+Y  S I=$P(^AMHREC(AMHSVDF,61,Y,0),U) W ?35,$P(^AMHTAXIV(I,0),U)_" - "_$P(^AMHTAXIV(I,0),U,2),!
  1.  .I '$O(^AMHREC(AMHSVDF,61,0)) W !
  1.  .W ?27,"AXIS V:  ",$P(^AMHREC(AMHSVDF,0),U,14) W:$P($G(^AMHREC(AMHSVDF,11)),U,15)]"" "  GAF Scale Type: ",$$VAL^XBDIQ1(9002011,AMHSVDF,1115),!
  1.  .Q
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  I $P(AMHSN,U,17)]"" W ?27,"Inpatient Disp:  ",$$VAL^XBDIQ1(9002011,AMHSVDF,.17),!?27,"Referred To:  ",$P(AMHSN,U,18),!
  1.  ;I $D(^AMHREC(AMHSVDF,12)) X APCHSCKP Q:$D(APCHSQIT)  S APCHSNRQ="COMMENT: "_^AMHREC(AMHSVDF,12),APCHSICL=27,APCHSTXT="" D PRTTXT^APCHSUTL
  1.  Q
  1.  ;
  1. NOPOV ;
  1.  S APCHSTXT="",(AMHSICD,APCHSNRQ)="<BH problem codes not yet entered>"
  1.  G COMMON
  1.  ;
  1. HASPOV ;
  1.  S APCHSNRQ=$P(^AMHPROB($P(AMHSR,U),0),U)_" - "
  1.  S AMHSICD=$E($P(^AMHPROB($P(AMHSR,U),0),U,2),1,45)
  1.  S Y=$L(APCHSNRQ) F X=Y:1:8 S APCHSNRQ=APCHSNRQ_" "
  1.  S APCHSNRQ=APCHSNRQ_AMHSICD,APCHSTXT="",APCHSICL=27
  1.  D COMMON
  1.  S:$P(AMHSR,U,4) APCHSNRQ=APCHSNRQ_$$GET1^DIQ(9002011.01,AMHSPDN,.04) S APCHSTXT="",APCHSICL=27 D PRTTXT^APCHSUTL
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  Q
  1. COMMON ;
  1.  X APCHSCKP Q:$D(APCHSQIT)  S:APCHSNPG AMHSNDT=1
  1.  I AMHSNDT W AMHSDAT S AMHSPFN="",AMHSNDT=0
  1.  W ?9,AMHSFAC,?18,$$PPINI^AMHUTIL(AMHSVDF),?22,AMHTOC S APCHSICL=27 D PRTTXT^APCHSUTL
  1.  Q
  1. DATE(D) ;
  1.  I $G(D)="" Q ""
  1.  Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))
  1. D(D) ;EP
  1.  I D="" Q ""
  1.  Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
  1.  ;
  1. MEAS ; ******************** MEASUREMENTS * *******
  1.  ; <SETUP>
  1.  Q:'$D(^AMHRMSR("AA",APCHSPAT))
  1.  ; <DISPLAY>
  1.  X APCHSCKP Q:$D(APCHSQIT)  S X="*********  BEHAVIORAL HEALTH Measurements ********* ",AMHS="",$P(AMHS," ",80-1-$L(X)/2)="" W !!,AMHS,X,AMHS,!
  1.  S APCHSMT="" F APCHSQ=0:0 S APCHSMT=$O(^AMHRMSR("AA",APCHSPAT,APCHSMT)) Q:APCHSMT=""  S APCHSND2=5 D MEASDTYP Q:$D(APCHSQIT)
  1.  ; <CLEANUP>
  1. MEASX ;
  1.  K APCHSMT,APCHSMT2,APCHSMT3,APCHSDFN,APCHSND2,APCHSDAT
  1.  Q
  1. MEASDTYP ;
  1.  S APCHSMT2=$S($D(^AUTTMSR(APCHSMT,0)):$P(^(0),U,1),1:APCHSMT) S APCHSMT3=APCHSMT2
  1.  S (APCHSIVD,APCHSDFN)="" F  S APCHSIVD=$O(^AMHRMSR("AA",APCHSPAT,APCHSMT,APCHSIVD)) Q:APCHSIVD=""  S APCHSND2=APCHSND2-1 Q:APCHSND2=-1  D MEASDSP
  1.  I APCHSMT3="" X APCHSCKP Q:$D(APCHSQIT)  W !
  1.  Q
  1. MEASDSP S APCHSDFN=$O(^AMHRMSR("AA",APCHSPAT,APCHSMT,APCHSIVD,"")),Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y X APCHSCKP Q:$D(APCHSQIT)  W:APCHSNPG!(APCHSMT3]"") APCHSMT2 S APCHSMT3="" W ?5,APCHSDAT,?18,$P(^AMHRMSR(APCHSDFN,0),U,4),!
  1.  Q
  1.  ;