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

AMHLEI2.m

Go to the documentation of this file. 
  1. AMHLEI2  ; IHS/TUCSON/LAB -VISIT DISPLAY ;        
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
  1.  ;
  1. DISP(DFN) ;EP
  1.  NEW AMHARRY
  1.  K ^TMP("AMHLEI1",$J)
  1.  S AMHARRY="^TMP(""AMHLEI1"",$J)"
  1.  Q:'$D(DFN)
  1.  Q:'DFN
  1.  Q:'$D(^AMHPINTK(DFN,0))
  1.  D BUILD
  1.  D XIT
  1.  Q
  1.  ;
  1. SET ;set array
  1.  S AMHCTR=AMHCTR+1
  1.  S @AMHARRY@(AMHCTR,0)=AMHSTR
  1.  S AMHSTR=""
  1.  Q
  1. BUILD ; build array
  1.  NEW AMHAR,AMHSTR,AMHX,AMHH,AMHV
  1.  I $E(IOST)'="P" D TERM^VALM0
  1.  S Y=DFN D ^AUPNPAT
  1.  S AMHSTR="",AMHCTR=0
  1.  S AMHH="Designated MH Provider",AMHV=$$VAL^XBDIQ1(9002011.55,DFN,.02) D BUILD1
  1.  S AMHH="Designated SS Provider",AMHV=$$VAL^XBDIQ1(9002011.55,DFN,.03) D BUILD1
  1.  S AMHH="Desg CD A/SA Provider",AMHV=$$VAL^XBDIQ1(9002011.55,DFN,.04) D BUILD1
  1.  S AMHH="Desg Other Provider",AMHV=$$VAL^XBDIQ1(9002011.55,DFN,.12) D BUILD1
  1.  S AMHH="Desg Other (2) Provider",AMHV=$$VAL^XBDIQ1(9002011.55,DFN,.13) D BUILD1
  1. INTAKE ;
  1.  S AMHSTR="=============== "_"BH INTAKE DOCUMENT"_" ===============",X=(80-$L(AMHSTR)\2) D SET ;$J("",X)_AMHSTR D SET
  1.  S AMHH="Initial Intake",AMHV=$$VAL^XBDIQ1(9002011.07,AMHINT,.07) D BUILD2
  1.  S AMHH="      Provider",AMHV=$$VAL^XBDIQ1(9002011.07,AMHINT,.08) D BUILD2
  1.  S AMHH="   Last Update",AMHV=$$VAL^XBDIQ1(9002011.07,AMHINT,.02) D BUILD2
  1.  S AMHH="      Provider",AMHV=$$VAL^XBDIQ1(9002011.07,AMHINT,.03) D BUILD2
  1.  S AMHSTR="" D SET
  1. 1 ;
  1.  I $O(^AMHPINTK(AMHINT,10,0)) D
  1.  .F AMHX=1000 I $D(^DD(9002011.07,AMHX,0)) D
  1.  ..S AMHSTR=$P(^DD(9002011.07,AMHX,0),U)_":" D SET
  1.  ..K AMHAR D ENP^XBDIQ1(9002011.07,DFN,AMHX,"AMHAR(","E")
  1.  ..S F=0 F  S F=$O(AMHAR(AMHX,F)) Q:F'=+F  S AMHSTR=AMHAR(AMHX,F) D SET
  1.  ..S AMHSTR="" D SET
  1.  .Q
  1.  F AMHX=4100 I $D(^DD(9002011.07,AMHX,0)) D
  1.  .S AMHSTR=$P(^DD(9002011.07,AMHX,0),U)_":" D SET
  1.  .K AMHAR D ENP^XBDIQ1(9002011.07,DFN,AMHX,"AMHAR(","E")
  1.  .S F=0 F  S F=$O(AMHAR(AMHX,F)) Q:F'=+F  S AMHSTR=AMHAR(AMHX,F) D SET
  1.  .S AMHSTR="" D SET
  1.  .Q
  1.  Q
  1. BUILD1 ;
  1.  S AMHSTR=$E(AMHH,1,35)_":",AMHSTR=$$SETSTR^VALM1(AMHV,AMHSTR,40,$L(AMHV))
  1.  D SET
  1.  Q
  1. BUILD2 ;
  1.  S AMHSTR=$E(AMHH,1,35)_":",AMHSTR=$$SETSTR^VALM1(AMHV,AMHSTR,26,$L(AMHV))
  1.  D SET
  1.  Q
  1. XIT ;
  1.  Q
  1. SENDINT ;EP
  1.  D FULL^VALM1
  1.  D SEND
  1.  D CLEAN
  1.  D BACK^AMHLEI
  1.  Q
  1. SEND ;
  1.  I '$D(^AMHSITE(DUZ(2),13,"B",DUZ)) Q  ;no access
  1.  S DIR(0)="Y",DIR("A")="Do you want to share this Intake Document with other Providers",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) Q
  1.  I 'Y Q
  1.  K XMY D GETLIST
  1.  I '$D(XMY) G SENDINT
  1.  W !!,"Intake Document as a message will be sent to:" S X=0 F  S X=$O(XMY(X)) Q:X'=+X  W ?28,$P(^VA(200,X,0),U),!
  1.  S DIR(0)="Y",DIR("A")="Ready to send mail message",DIR("B")="Y" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) K XMY,XMTEXT,XMDUZ,XMZ,XMSUB,AMHEFT Q
  1.  I 'Y K XMY,XMTEXT,XMDUZ,XMZ,XMSUB G SENDINT
  1.  D MAILMSG
  1.  Q
  1. GETLIST ;
  1.  K XMY
  1. GETLIST1 ;
  1.  K DIC,DR,DD,D0,DO S DIC="^VA(200,",DIC(0)="AEMQ",DIC("A")="Send to: " D ^DIC
  1.  I Y=-1 Q
  1.  S XMY(+Y)=""
  1.  G GETLIST1
  1.  ;
  1. MAILMSG ;
  1.  K ^TMP("AMHLEI1",$J)
  1.  D ^XBFMK
  1.  ;S AMHX=0 F  S AMHX=$O(XMY(AMHX)) Q:AMHX'=+AMHX  D
  1.  ;.I '$D(^AMHREC(AMHR,52,"B",AMHX)) S DA=AMHR,DIE="^AMHREC(",DR="5200///`"_AMHX D ^DIE
  1.  D DISP(DFN)
  1.  S (C,X)=0 F  S X=$O(^TMP("AMHLEI1",$J,X)) Q:X'=+X  S C=C+1
  1.  S C=C+1,^TMP("AMHLEI1",$J,C)="THIS FORM CONTAINS CONFIDENTIAL PATIENT INFORMATION.  UNAUTHORIZED"
  1.  S C=C+1,^TMP("AMHLEI1",$J,C)="REPRODUCTION OF THIS FORM MAY VIOLATE PRIVACY ACT STATUTES AND BE"
  1.  S C=C+1,^TMP("AMHLEI1",$J,C)="PUNISHABLE BY LAW."
  1.  S C=C+1,^TMP("AMHLEI1",$J,C)="*********** PLEASE DELETE IMMEDIATELY AFTER REVIEW. ***********"
  1.  S XMSUB="Intake Document - Behavioral Health - CONFIDENTIAL"
  1.  S XMDUZ=$P(^VA(200,DUZ,0),U)
  1.  D XMZ^XMA2
  1.  S AMHXMZ=XMZ
  1.  S XMDUZ=$P(^VA(200,DUZ,0),U)
  1.  S XMTEXT="^TMP(""AMHLEI1"",$J,"
  1.  W !,"Sending Mailman message to distribution list"
  1.  D ENL^XMD
  1.  S XMZ=AMHXMZ
  1.  S DA=XMZ,DIE=3.9,DR="1.95///Y;1.96///Y" D ^DIE K DIE,DR,DA
  1.  D ENT1^XMD
  1.  KILL ^TMP("AMHLEI1",$J)
  1.  ;set multiple imn record file
  1.  ;kill vars
  1.  K XMZ,DA,DIE,DR,XMDUZ,AMHXMZ,AMHEFT,XMSUB,AMHX,XMY
  1.  W !,"Message Sent  "
  1.  D PAUSE^AMHLEP2
  1.  Q
  1. CLEAN ;
  1.  K AMHX,AMHY,XMY,XMTEXT,XMDUZ,XMZ,XMSUB,AMHXMZ
  1.  D ^XBFMK
  1.  Q
  1.  ;