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