AMHLEIV ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 16-JAN-1997 14 Sep 2009 12:21 PM ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;; ;
;
EP1(AMHR,P) ;EP - CALLED FROM PROTOCOL FROM THE OTHER INFORMATION MENU AFTER VISIT ENTRY
I '$G(AMHR) D FULL^VALM1 W !!,"You must first select a visit." D PAUSE^AMHLEA Q
NEW AMHBROW,AMHD,AMHDA,AMHFILE,AMHINTK,AMHL,AMHLINE,AMHNODE,AMHPC,AMHPCNT,AMHPRNM,AMHPRNT,AMHQUIT,AMHR1,AMHRCNT,AMHINTI,AMHPROGT,AMHFIRST
NEW AMHV,AMHX,D,D0,DA,DD,DIADD,DIC,DIE,DIK,DIR,DIRUT,DLAYGO,DO,DR,AMHPAT,DFN
S (DFN,AMHPAT)=P
S AMHPROGT=$P(^AMHREC(AMHR,0),U,2)
D EN
D FULL^VALM1
K VALMHDR
Q
EP ;EP CALLED FROM DATA ENTRY
Q:'$G(AMHR)
NEW DFN,AMHPAT,AMHPROGT
S (DFN,AMHPAT)=$P(^AMHREC(AMHR,0),U,8)
S Y=AMHPAT D ^AUPNPAT
S AMHPROGT=$P(^AMHREC(AMHR,0),U,2)
D EN
Q
EN ; -- main entry point for AMH UPDATE PATIENT CASE DATA
NEW AMHX,AMHINTK,AMHD,AMHRCNT,AMHLINE
D EN^VALM("AMH VISIT INTAKE")
Q
;
HDR ;EP -- header code
S VALMHDR(1)=$$EXTSET^XBFUNC(9002011,.02,AMHPROGT)_" INTAKE DOCUMENTS *unsigned document"
S VALMHDR(2)="Patient Name: "_IORVON_$P(^DPT(DFN,0),U)_IOINORM_" DOB: "_$$FTIME^VALM1($P(^DPT(DFN,0),U,3))_" Sex: "_$P(^DPT(DFN,0),U,2)_" HRN: "_$S($D(^AUPNPAT(DFN,41,DUZ(2),0)):$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2),1:"????")
S X="",$E(X,4)="",$E(X,24)="INITIAL",$E(X,44)="",$E(X,53)="UPDATE"
S VALMHDR(3)=X
S X="",$E(X,1)="#",$E(X,4)="INITIATED",$E(X,15)="PROGRAM",$E(X,24)="PROVIDER",$E(X,44)="UPDATED",$E(X,53)="PROVIDER"
S VALMHDR(4)=X
;S X="",$E(X,44)="UPDATED",$E(X,53)="PROVIDER"
;S VALMHDR(5)=X
Q
;
INIT ; -- init variables and list array
S VALMSG="?? for more actions + next screen - prev screen"
D GATHER ;gather up all records for display
S VALMCNT=AMHLINE
Q
;
D(D) ;EP
I D="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
;
GATHER ;EP
S AMHRCNT=0,AMHLINE=0
K AMHV
S AMHX=0 F S AMHX=$O(^AMHRINTK("AC",AMHPAT,AMHX)) Q:AMHX'=+AMHX D
.;S AMHINTR=$P(^AMHRINTK(AMHX,0),U,3)
.;Q:'AMHINTR
.Q:'$$ALLOWINT(DUZ,AMHX)
.I $P(^AMHRINTK(AMHX,0),U,5)]"" Q:$P(^AMHRINTK(AMHX,0),U,5)'=AMHPROGT
.Q:$P(^AMHRINTK(AMHX,0),U,9)'="I" ;only initial intakes
.S AMHV(9999999-$P(^AMHRINTK(AMHX,0),U),AMHX)=""
S D=0,AMHLINE=0,AMHRCNT=0
F S D=$O(AMHV(D)) Q:D'=+D D
.S AMHX=0 F S AMHX=$O(AMHV(D,AMHX)) Q:AMHX'=+AMHX D
..S AMHL="",AMHRCNT=AMHRCNT+1,AMHL=$S('$P(^AMHRINTK(AMHX,0),U,11):"*",1:""),AMHL=AMHL_AMHRCNT,$E(AMHL,5)=$$D($P(^AMHRINTK(AMHX,0),U))
..S $E(AMHL,15)=$E($$VAL^XBDIQ1(9002011.13,AMHX,.05),1,8)
..S $E(AMHL,24)=$E($$VAL^XBDIQ1(9002011.13,AMHX,.04),1,19)
..S AMHLINE=AMHLINE+1,AMHINTK(AMHLINE,0)=AMHL,AMHINTK("IDX",AMHLINE,AMHRCNT)=AMHX
..S AMHY=0 F S AMHY=$O(^AMHRINTK("AI",AMHX,AMHY)) Q:AMHY'=+AMHY D
...S AMHL=""
...S $E(AMHL,43)=$S('$P(^AMHRINTK(AMHY,0),U,11):"*",1:"")
...S $E(AMHL,44)=$$D($P($P(^AMHRINTK(AMHY,0),U),"."))
...S $E(AMHL,53)=$$VAL^XBDIQ1(9002011.13,AMHY,.04)
...S AMHLINE=AMHLINE+1,AMHINTK(AMHLINE,0)=AMHL,AMHINTK("IDX",AMHLINE,AMHRCNT)=AMHX
Q
ADD ;
;add a new intake document
D FULL^VALM1
S AMHIDAT=""
I $G(AMHR) S AMHIDAT=$P($P(^AMHREC(AMHR,0),U),".")
I AMHIDAT="" S AMHIDAT=$P($G(AMHDATE),".",1)
I AMHIDAT="" S AMHIDAT=DT
NEW X,Y,Z
S Y=0
;S X=0 F S X=$O(^AMHRINTK("AD",AMHR,X)) Q:X'=+X I $P(^AMHRINTK(X,0),U,9)="I" S Y=1
;I Y=1 W !!,"There is already an Initial Intake on this visit.",! D PAUSE^AMHLEA,EXIT Q
W !,"Adding Intake for ",$$VAL^XBDIQ1(2,AMHPAT,.01) ;," with a date of ",$$FMTE^XLFDT(AMHIDAT),"."
S DIR(0)="Y",DIR("A")="Do you wish to continue and add the Initial Intake document",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D PAUSE^AMHLEA,EXIT Q
I 'Y D PAUSE^AMHLEA,EXIT Q
;create and update
S X=AMHIDAT,DIC(0)="L",DIC="^AMHRINTK(",DLAYGO=9002011.13,DIADD=1,DIC("DR")=".02////"_AMHPAT_";.05///"_AMHPROGT_";.07////"_DT_";.09///I;.13////"_DUZ
K DD,D0,DO
D FILE^DICN
K DIC,DLAYGO,DIADD
I Y=-1 W !!,"error creating Initial Intake document...." D PAUSE^AMHLEA,EXIT Q
S AMHRINTI=+Y
;update 11 multiple and .07
S AMHPROVN=$S($G(AMHR):$$PRIMPROV^AMHUTIL(AMHR,"N"),1:$P(^VA(200,DUZ,0),U,1))
S DA=AMHRINTI,DIE="^AMHRINTK(",DR=".01;.05;.04//"_AMHPROVN_";.07;4100",DIE("NO^")="" D ^DIE K DIE,DA
S DA=AMHRINTI,DIE="^AMHRINTK(",DR=".06////"_DUZ_";.13////"_DUZ,DIE("NO^")="" D ^DIE K DA,DIE,DR
W !!,"Initial Intake document created..." D SIGNINT(AMHRINTI)
D PAUSE^AMHLEA
D EXIT
Q
SIGNINT(AMHRX) ;sign intake
SIGNINT1 K AMHXX
S AMHXX=$$ESIGINT^AMHESIG(AMHRX)
I '$G(AMHXX) D I $P(AMHXX,U,4),AMHANS G SIGNINT1
.W !!,$P(AMHXX,U,3),!
.I '$P(AMHXX,U,4) Q
.S DIR(0)="Y",DIR("A")="Do you wish to enter an Intake Narrative",DIR("B")="Y" KILL DA D ^DIR KILL DIR
.Q:$D(DIRUT)
.S AMHANS=Y Q:'Y
.S DIE="^AMHRINTK(",DR=4100,DA=AMHRX D ^DIE K DA,DIE,DR
I AMHXX D ESIGGFII^AMHESIG(AMHRX)
Q
;
ALLOWINT(P,I) ;EP
;P - DUZ, user internal entry number
;I - intake ien
I '$G(P) Q 0
I '$G(I) Q 0
NEW R,G
I $D(^AMHSITE(DUZ(2),16,P)) Q 1 ;allow all with access
I $P(^AMHRINTK(I,0),U,4)=P Q 1
I $P(^AMHRINTK(I,0),U,6)=P Q 1
I $P(^AMHRINTK(I,0),U,13)=P Q 1
I $P(^AMHRINTK(I,0),U,4)="" Q 1
S R=0,G=0 F S R=$O(^AMHRINTK("AI",I,R)) Q:R'=+R D
.I $P(^AMHRINTK(R,0),U,4)=P S G=1
.I $P(^AMHRINTK(R,0),U,6)=P S G=1
.I $P(^AMHRINTK(R,0),U,13)=P S G=1
Q G
EDIT ;
S AMHRINTI=""
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." G EXIT
S AMHR1=$O(VALMY(0)) I 'AMHR1 K AMHR1,VALMY,XQORNOD W !,"No record selected." G EXIT
S (X,Y)=0 F S X=$O(AMHINTK("IDX",X)) Q:X'=+X!(AMHRINTI) I $O(AMHINTK("IDX",X,0))=AMHR1 S Y=$O(AMHINTK("IDX",X,0)),AMHRINTI=AMHINTK("IDX",X,Y)
I '$D(^AMHRINTK(AMHRINTI,0)) W !,"Not a valid BH INTAKE." D PAUSE^AMHLEA D EXIT Q
I $P(^AMHRINTK(AMHRINTI,0),U,9)'="I" W !!,"This is not an Initial Intake. Use option U to edit an Update to",!,"an Intake document." D PAUSE^AMHLEA,EXIT Q
D FULL^VALM1
I $P(^AMHRINTK(AMHRINTI,0),U,11) W !!,"This Initial Intake document has been signed. You cannot edit it." D PAUSE^AMHLEA,EXIT Q
;I $P(^AMHRINTK(AMHRINTI,0),U,3)'=AMHR D Q
;.W !!,"This Intake is not associated with the visit your are currently processing.",!,"To edit this Intake document you must use Edit Visit and edit the visit",!,"on "_$$VAL^XBDIQ1(9002011.13,AMHRINTI,.03),"." D PAUSE^AMHLEA,EXIT Q
I $$VALI^XBDIQ1(9002011.13,AMHRINTI,.04)'=DUZ&(DUZ'=$$VALI^XBDIQ1(9002011.13,AMHRINTI,.13))&(DUZ'=$$VALI^XBDIQ1(9002011.13,AMHRINTI,.06)) D D PAUSE^AMHLEA,EXIT Q
.W !,"You are not the original provider or the person who entered or ",!,"modified this document. You cannot edit it."
S DA=AMHRINTI,DIE="^AMHRINTK(",DR=".01"_$S('$O(^AMHRINTK("AI",AMHRINTI,0)):";.05",1:"")_";.04;.06////^S X=DUZ;.07//^S X=DT"_";4100" D ^DIE K DIE,DR,DA
;I '$O(^AMHRINTK("AI",AMHRINTI,0)) S DIE="^AMHRINTK(",DA=AMHRINTI,DR=".05" D ^DIE K DIE,DA,DR
;S DIE="^AMHRINTK(",DA=AMHRINTI,DR=".04;.06////^S X=DUZ;.07//^S X=DT"_";4100" D ^DIE K DIE,DR,DA
;set visit multiple, .07
;S DA=AMHRINTI,DIE="^AMHRINTK(",DR=".07////"_DT,DIE("NO^")="" D ^DIE K DIE,DA,DR
;S DA=AMHRINTI,DIE="^AMHRINTK(",DR=4100,DIE("NO^")="" D ^DIE
W !!,"Initial Intake document updated...." D SIGNINT(AMHRINTI),PAUSE^AMHLEA
D EXIT
Q
PRINT ;
S AMHRINTI=""
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." G EXIT
S AMHR1=$O(VALMY(0)) I 'AMHR1 K AMHR1,VALMY,XQORNOD W !,"No record selected." G EXIT
S (X,Y)=0 F S X=$O(AMHINTK("IDX",X)) Q:X'=+X!(AMHRINTI) I $O(AMHINTK("IDX",X,0))=AMHR1 S Y=$O(AMHINTK("IDX",X,0)),AMHRINTI=AMHINTK("IDX",X,Y)
I '$D(^AMHRINTK(AMHRINTI,0)) W !,"Not a valid BH INTAKE." D PAUSE^AMHLEA D EXIT Q
D FULL^VALM1
D PRINT^AMHLEIV3
D PAUSE^AMHLEA
D EXIT
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ;EP -- exit code
K AMHX,AMHINTK,AMHPC,AMHR1
D TERM^VALM0
S VALMBCK="R"
D GATHER
S VALMCNT=AMHLINE
D HDR
K X,Y,Z,I
Q
;
EXPND ; -- expand code
Q
;
DEL ;EP - called from protocol entry
NEW AMHY,AMHRINTI,AMHX,AMHZ,AMHC,AMHC1,AMHRINT,AMHRIU
D FULL^VALM1
I '$D(^XUSEC("AMHZ DELETE RECORD",DUZ)),'$D(^AMHSITE(DUZ(2),21,"B",DUZ)) W !!,"You do not have the security access to delete an Intake document.",!,"Please see your supervisor or program manager.",! D PAUSE^AMHLEA,EXIT Q
S AMHRINTI=""
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." G EXIT
S AMHR1=$O(VALMY(0)) I 'AMHR1 K AMHR1,VALMY,XQORNOD W !,"No record selected." G EXIT
S (X,Y)=0 F S X=$O(AMHINTK("IDX",X)) Q:X'=+X!(AMHRINTI) I $O(AMHINTK("IDX",X,0))=AMHR1 S Y=$O(AMHINTK("IDX",X,0)),AMHRINTI=AMHINTK("IDX",X,Y)
I '$D(^AMHRINTK(AMHRINTI,0)) W !,"Not a valid BH INTAKE." D PAUSE^AMHLEA D EXIT Q
DEL1 ;are you sure??
K AMHY
I '$D(^AMHRINTK(AMHRINTI)) D EXIT Q
S AMHY(1)=AMHRINTI,AMHC=1
S AMHX=0 F S AMHX=$O(^AMHRINTK("AI",AMHRINTI,AMHX)) Q:AMHX'=+AMHX S AMHC=AMHC+1,AMHY(AMHC)=AMHX
W !!,"You can now select which Intake or Update document to delete. Initial Intake ",!,"documents that have Updates associated with them cannot be deleted.",!
W !?5,"0",?10,"Quit/Exit"
S X=0,AMHC=0 F S AMHC=$O(AMHY(AMHC)) Q:AMHC'=+AMHC S AMHX=AMHY(AMHC) D
.S AMHINTR=$P(^AMHRINTK(AMHX,0),U,3)
.S AMHC1=AMHC W !?5,AMHC,?10,"Date: ",$$D($$VALI^XBDIQ1(9002011.13,AMHX,.01))," Provider: ",$E($$VAL^XBDIQ1(9002011.13,AMHX,.04),1,15),?51,$E($$VAL^XBDIQ1(9002011.13,AMHX,.05),1,13),?65,$$VAL^XBDIQ1(9002011.13,AMHX,.09)
W !
S DIR(0)="N^0:"_AMHC1_":0",DIR("A")="Select Action",DIR("B")="0" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D EXIT Q
I Y=0 D EXIT Q
S AMHRINT=AMHY(Y)
S AMHRIU=$P(^AMHRINTK(AMHRINT,0),U,9)
I $D(^AMHSITE(DUZ(2),21,"B",DUZ)) G DISP
I $P(^AMHRINTK(AMHRINT,0),U,4)'=DUZ&(DUZ'=$P(^AMHRINTK(AMHRINT,0),U,13))&(DUZ'=$P(^AMHRINTK(AMHRINT,0),U,6)) D D PAUSE^AMHLEA G DEL1
.W !!,"You are not the provider or the person who entered this "_$S(AMHRIU="I":"Initial Intake",1:"Update"),!,"document, you cannot delete it."
I $P(^AMHRINTK(AMHRINT,0),U,11),'$D(^XUSEC("AMHZ DELETE SIGNED NOTE",DUZ)) D G DEL1
.W !!,"You cannot delete this "_$S(AMHRIU="I":"Initial Intake",1:"Update")_" document, it has been electronically signed.",!,"Please see your supervisor or program manager." D PAUSE^AMHLEA Q
DISP ;
I $P(^AMHRINTK(AMHRINT,0),U,9)="I",$D(^AMHRINTK("AI",AMHRINT)) W !!,"This Initial Intake has Updates associated with it, it cannot be deleted." D PAUSE^AMHLEA G DEL1
S DA=AMHRINT,DIC="^AMHRINTK(" D EN^DIQ
S DIR(0)="Y",DIR("A")="Are you sure you want to delete this "_$S(AMHRIU="I":"Initial Intake",1:"Update")_" document",DIR("B")="N" KILL DA D ^DIR KILL DIR ;LORI
I 'Y W !!,$S(AMHRIU="I":"Initial Intake",1:"Update")_" document not deleted." D PAUSE^AMHLEA G DEL1
S DA=AMHRINT,DIK="^AMHRINTK(" D ^DIK
K DA,DIK
;
W !!,$S(AMHRIU="I":"Initial Intake",1:"Update")_" document deleted." D PAUSE^AMHLEA
G DEL1
Q
UPD ;
NEW AMHR1,X,AMHRINTI,AMHX,AMHY,AMHC,AMHA,AMHRINTU
S AMHRINTI=""
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." G EXIT
S AMHR1=$O(VALMY(0)) I 'AMHR1 K AMHR1,VALMY,XQORNOD W !,"No record selected." G EXIT
S (X,Y)=0 F S X=$O(AMHINTK("IDX",X)) Q:X'=+X!(AMHRINTI) I $O(AMHINTK("IDX",X,0))=AMHR1 S Y=$O(AMHINTK("IDX",X,0)),AMHRINTI=AMHINTK("IDX",X,Y)
I '$D(^AMHRINTK(AMHRINTI,0)) W !,"Not a valid BH INTAKE." D PAUSE^AMHLEA D EXIT Q
;I $P(^AMHRINTK(AMHRINTI,0),U,9)'="I" W !!,"This is not an Initial Intake. Use option U to edit an update to",!,"an intake document." D PAUSE^AMHLEA,EXIT Q
D FULL^VALM1
;I $P(^AMHRINTK(AMHRINTI,0),U,11) W !!,"This intake document has been signed. You cannot edit it." D PAUSE^AMHLEA,EXIT Q
;display all updates for this initial intake
UPD1 ;
K AMHY
S AMHC=0,AMHX=0 F S AMHX=$O(^AMHRINTK("AI",AMHRINTI,AMHX)) Q:AMHX'=+AMHX S AMHC=AMHC+1,AMHY(AMHC)=AMHX
S AMHA=AMHC+1
W !!,"You can either add a new Update to this Intake document or edit an "
W !,"existing, unsigned one on which you are the provider. Please select an Update"
W !,"to edit or choose ",AMHA," to add a new one or 0 to quit.",!
W !?5,"0",?10,"Quit/Exit Update"
S X=0,AMHC=0 F S AMHC=$O(AMHY(AMHC)) Q:AMHC'=+AMHC S AMHX=AMHY(AMHC) D
.;S AMHINTR=$P(^AMHRINTK(AMHX,0),U,3)
.W !?5,AMHC,?10,"Date Updated: ",$$D($$VALI^XBDIQ1(9002011.13,AMHX,.01))," Provider: ",$E($$VAL^XBDIQ1(9002011.13,AMHX,.04),1,20),?66,$E($$VAL^XBDIQ1(9002011.13,AMHX,.05),1,13)
W !?5,AMHA,?10,"Add new Update document",!
S DIR(0)="N^0:"_AMHA_":0",DIR("A")="Select Action",DIR("B")="0" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D EXIT Q
I Y=AMHA D ADDUPD,PAUSE^AMHLEA G UPD1
I Y=0 D EXIT Q
S AMHRINTU=AMHY(Y)
UPDE ;
I $P(^AMHRINTK(AMHRINTU,0),U,11) W !!,"This Intake Update document has been signed. You cannot edit it." D PAUSE^AMHLEA G UPD1
;I $P(^AMHRINTK(AMHRINTI,0),U,3)'=AMHR D Q
;.W !!,"This Update document is not associated with the visit your are currently processing.",!,"To edit this Update document you must use Edit Visit and edit the visit",!,"on "_$$VAL^XBDIQ1(9002011.13,AMHRINTI,.03),"." D PAUSE^AMHLEA,EXIT Q
I $$VALI^XBDIQ1(9002011.13,AMHRINTU,.04)'=DUZ&(DUZ'=$P(^AMHRINTK(AMHRINTU,0),U,13))&(DUZ'=$$VALI^XBDIQ1(9002011.13,AMHRINTU,.06)) D D PAUSE^AMHLEA G UPD1
.W !,"You are not the original provider or the person who entered/edited this ",!,"document. You cannot edit it."
S DA=AMHRINTU,DIE="^AMHRINTK(",DR=".01;.04;.06////^S X=DUZ;.07////"_DT_";.07;4100" D ^DIE K DIE,DR,DA
;set visit multiple, .07
;S DA=AMHRINTI,DIE="^AMHRINTK(",DR=".07////"_DT,DIE("NO^")="" D ^DIE K DIE,DA,DR
;S DA=AMHRINTI,DIE="^AMHRINTK(",DR=4100,DIE("NO^")="" D ^DIE
W !!,"Intake Update document updated...." D SIGNINT(AMHRINTU),PAUSE^AMHLEA G UPD1
Q
ADDUPD ;
D FULL^VALM1
S AMHIDAT=""
I $G(AMHR) S AMHIDAT=$P($P(^AMHREC(AMHR,0),U),".")
I AMHIDAT="" S AMHIDAT=$P($G(AMHDATE),".",1)
I AMHIDAT="" S AMHIDAT=DT
W !,"Adding Intake Update for ",$$VAL^XBDIQ1(2,AMHPAT,.01) ;," with a date of ",$$FMTE^XLFDT(AMHIDAT),"."
S DIR(0)="Y",DIR("A")="Do you wish to continue on to add the Intake Update",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D PAUSE^AMHLEA,EXIT Q
I 'Y D PAUSE^AMHLEA,EXIT Q
;create and update
S X=AMHIDAT,DIC(0)="L",DIC="^AMHRINTK(",DLAYGO=9002011.13,DIADD=1,DIC("DR")=".02////"_AMHPAT_";.05///"_$$VAL^XBDIQ1(9002011.13,AMHRINTI,.05)_";.07////"_DT_";.09///U;.13////"_DUZ_";.1////"_AMHRINTI
K DD,D0,DO
D FILE^DICN
K DIC,DLAYGO,DIADD
I Y=-1 W !!,"Error creating Update to the Intake document...." Q
S AMHRINTU=+Y
;update 11 multiple and .07
S AMHPROVN=$S($G(AMHR):$$PRIMPROV^AMHUTIL(AMHR,"N"),1:$P(^VA(200,DUZ,0),U,1))
S DA=AMHRINTU,DIE="^AMHRINTK(",DR=".01;.04//"_AMHPROVN_";.07;4100",DIE("NO^")="" D ^DIE K DIE,DA
S DA=AMHRINTU,DIE="^AMHRINTK(",DR=".06////"_DUZ,DIE("NO^")="" D ^DIE K DA,DIE,DR
W !!,"Intake Update document created..." D SIGNINT(AMHRINTU)
Q
AMHLEIV ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 16-JAN-1997 14 Sep 2009 12:21 PM ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;; ;
+3 ;
EP1(AMHR,P) ;EP - CALLED FROM PROTOCOL FROM THE OTHER INFORMATION MENU AFTER VISIT ENTRY
+1 IF '$GET(AMHR)
DO FULL^VALM1
WRITE !!,"You must first select a visit."
DO PAUSE^AMHLEA
QUIT
+2 NEW AMHBROW,AMHD,AMHDA,AMHFILE,AMHINTK,AMHL,AMHLINE,AMHNODE,AMHPC,AMHPCNT,AMHPRNM,AMHPRNT,AMHQUIT,AMHR1,AMHRCNT,AMHINTI,AMHPROGT,AMHFIRST
+3 NEW AMHV,AMHX,D,D0,DA,DD,DIADD,DIC,DIE,DIK,DIR,DIRUT,DLAYGO,DO,DR,AMHPAT,DFN
+4 SET (DFN,AMHPAT)=P
+5 SET AMHPROGT=$PIECE(^AMHREC(AMHR,0),U,2)
+6 DO EN
+7 DO FULL^VALM1
+8 KILL VALMHDR
+9 QUIT
EP ;EP CALLED FROM DATA ENTRY
+1 IF '$GET(AMHR)
QUIT
+2 NEW DFN,AMHPAT,AMHPROGT
+3 SET (DFN,AMHPAT)=$PIECE(^AMHREC(AMHR,0),U,8)
+4 SET Y=AMHPAT
DO ^AUPNPAT
+5 SET AMHPROGT=$PIECE(^AMHREC(AMHR,0),U,2)
+6 DO EN
+7 QUIT
EN ; -- main entry point for AMH UPDATE PATIENT CASE DATA
+1 NEW AMHX,AMHINTK,AMHD,AMHRCNT,AMHLINE
+2 DO EN^VALM("AMH VISIT INTAKE")
+3 QUIT
+4 ;
HDR ;EP -- header code
+1 SET VALMHDR(1)=$$EXTSET^XBFUNC(9002011,.02,AMHPROGT)_" INTAKE DOCUMENTS *unsigned document"
+2 SET VALMHDR(2)="Patient Name: "_IORVON_$PIECE(^DPT(DFN,0),U)_IOINORM_" DOB: "_$$FTIME^VALM1($PIECE(^DPT(DFN,0),U,3))_" Sex: "_$PIECE(^DPT(DFN,0),U,2)_" HRN: "_$SELECT($DATA(^AUPNPAT(DFN,41,DUZ(2),0)):$PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2),
1:"????")
+3 SET X=""
SET $EXTRACT(X,4)=""
SET $EXTRACT(X,24)="INITIAL"
SET $EXTRACT(X,44)=""
SET $EXTRACT(X,53)="UPDATE"
+4 SET VALMHDR(3)=X
+5 SET X=""
SET $EXTRACT(X,1)="#"
SET $EXTRACT(X,4)="INITIATED"
SET $EXTRACT(X,15)="PROGRAM"
SET $EXTRACT(X,24)="PROVIDER"
SET $EXTRACT(X,44)="UPDATED"
SET $EXTRACT(X,53)="PROVIDER"
+6 SET VALMHDR(4)=X
+7 ;S X="",$E(X,44)="UPDATED",$E(X,53)="PROVIDER"
+8 ;S VALMHDR(5)=X
+9 QUIT
+10 ;
INIT ; -- init variables and list array
+1 SET VALMSG="?? for more actions + next screen - prev screen"
+2 ;gather up all records for display
DO GATHER
+3 SET VALMCNT=AMHLINE
+4 QUIT
+5 ;
D(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+3 ;
GATHER ;EP
+1 SET AMHRCNT=0
SET AMHLINE=0
+2 KILL AMHV
+3 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRINTK("AC",AMHPAT,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+4 ;S AMHINTR=$P(^AMHRINTK(AMHX,0),U,3)
+5 ;Q:'AMHINTR
+6 IF '$$ALLOWINT(DUZ,AMHX)
QUIT
+7 IF $PIECE(^AMHRINTK(AMHX,0),U,5)]""
IF $PIECE(^AMHRINTK(AMHX,0),U,5)'=AMHPROGT
QUIT
+8 ;only initial intakes
IF $PIECE(^AMHRINTK(AMHX,0),U,9)'="I"
QUIT
+9 SET AMHV(9999999-$PIECE(^AMHRINTK(AMHX,0),U),AMHX)=""
End DoDot:1
+10 SET D=0
SET AMHLINE=0
SET AMHRCNT=0
+11 FOR
SET D=$ORDER(AMHV(D))
IF D'=+D
QUIT
Begin DoDot:1
+12 SET AMHX=0
FOR
SET AMHX=$ORDER(AMHV(D,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:2
+13 SET AMHL=""
SET AMHRCNT=AMHRCNT+1
SET AMHL=$SELECT('$PIECE(^AMHRINTK(AMHX,0),U,11):"*",1:"")
SET AMHL=AMHL_AMHRCNT
SET $EXTRACT(AMHL,5)=$$D($PIECE(^AMHRINTK(AMHX,0),U))
+14 SET $EXTRACT(AMHL,15)=$EXTRACT($$VAL^XBDIQ1(9002011.13,AMHX,.05),1,8)
+15 SET $EXTRACT(AMHL,24)=$EXTRACT($$VAL^XBDIQ1(9002011.13,AMHX,.04),1,19)
+16 SET AMHLINE=AMHLINE+1
SET AMHINTK(AMHLINE,0)=AMHL
SET AMHINTK("IDX",AMHLINE,AMHRCNT)=AMHX
+17 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHRINTK("AI",AMHX,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:3
+18 SET AMHL=""
+19 SET $EXTRACT(AMHL,43)=$SELECT('$PIECE(^AMHRINTK(AMHY,0),U,11):"*",1:"")
+20 SET $EXTRACT(AMHL,44)=$$D($PIECE($PIECE(^AMHRINTK(AMHY,0),U),"."))
+21 SET $EXTRACT(AMHL,53)=$$VAL^XBDIQ1(9002011.13,AMHY,.04)
+22 SET AMHLINE=AMHLINE+1
SET AMHINTK(AMHLINE,0)=AMHL
SET AMHINTK("IDX",AMHLINE,AMHRCNT)=AMHX
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT
ADD ;
+1 ;add a new intake document
+2 DO FULL^VALM1
+3 SET AMHIDAT=""
+4 IF $GET(AMHR)
SET AMHIDAT=$PIECE($PIECE(^AMHREC(AMHR,0),U),".")
+5 IF AMHIDAT=""
SET AMHIDAT=$PIECE($GET(AMHDATE),".",1)
+6 IF AMHIDAT=""
SET AMHIDAT=DT
+7 NEW X,Y,Z
+8 SET Y=0
+9 ;S X=0 F S X=$O(^AMHRINTK("AD",AMHR,X)) Q:X'=+X I $P(^AMHRINTK(X,0),U,9)="I" S Y=1
+10 ;I Y=1 W !!,"There is already an Initial Intake on this visit.",! D PAUSE^AMHLEA,EXIT Q
+11 ;," with a date of ",$$FMTE^XLFDT(AMHIDAT),"."
WRITE !,"Adding Intake for ",$$VAL^XBDIQ1(2,AMHPAT,.01)
+12 SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue and add the Initial Intake document"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+13 IF $DATA(DIRUT)
DO PAUSE^AMHLEA
DO EXIT
QUIT
+14 IF 'Y
DO PAUSE^AMHLEA
DO EXIT
QUIT
+15 ;create and update
+16 SET X=AMHIDAT
SET DIC(0)="L"
SET DIC="^AMHRINTK("
SET DLAYGO=9002011.13
SET DIADD=1
SET DIC("DR")=".02////"_AMHPAT_";.05///"_AMHPROGT_";.07////"_DT_";.09///I;.13////"_DUZ
+17 KILL DD,D0,DO
+18 DO FILE^DICN
+19 KILL DIC,DLAYGO,DIADD
+20 IF Y=-1
WRITE !!,"error creating Initial Intake document...."
DO PAUSE^AMHLEA
DO EXIT
QUIT
+21 SET AMHRINTI=+Y
+22 ;update 11 multiple and .07
+23 SET AMHPROVN=$SELECT($GET(AMHR):$$PRIMPROV^AMHUTIL(AMHR,"N"),1:$PIECE(^VA(200,DUZ,0),U,1))
+24 SET DA=AMHRINTI
SET DIE="^AMHRINTK("
SET DR=".01;.05;.04//"_AMHPROVN_";.07;4100"
SET DIE("NO^")=""
DO ^DIE
KILL DIE,DA
+25 SET DA=AMHRINTI
SET DIE="^AMHRINTK("
SET DR=".06////"_DUZ_";.13////"_DUZ
SET DIE("NO^")=""
DO ^DIE
KILL DA,DIE,DR
+26 WRITE !!,"Initial Intake document created..."
DO SIGNINT(AMHRINTI)
+27 DO PAUSE^AMHLEA
+28 DO EXIT
+29 QUIT
SIGNINT(AMHRX) ;sign intake
SIGNINT1 KILL AMHXX
+1 SET AMHXX=$$ESIGINT^AMHESIG(AMHRX)
+2 IF '$GET(AMHXX)
Begin DoDot:1
+3 WRITE !!,$PIECE(AMHXX,U,3),!
+4 IF '$PIECE(AMHXX,U,4)
QUIT
+5 SET DIR(0)="Y"
SET DIR("A")="Do you wish to enter an Intake Narrative"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
QUIT
+7 SET AMHANS=Y
IF 'Y
QUIT
+8 SET DIE="^AMHRINTK("
SET DR=4100
SET DA=AMHRX
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
IF $PIECE(AMHXX,U,4)
IF AMHANS
GOTO SIGNINT1
+9 IF AMHXX
DO ESIGGFII^AMHESIG(AMHRX)
+10 QUIT
+11 ;
ALLOWINT(P,I) ;EP
+1 ;P - DUZ, user internal entry number
+2 ;I - intake ien
+3 IF '$GET(P)
QUIT 0
+4 IF '$GET(I)
QUIT 0
+5 NEW R,G
+6 ;allow all with access
IF $DATA(^AMHSITE(DUZ(2),16,P))
QUIT 1
+7 IF $PIECE(^AMHRINTK(I,0),U,4)=P
QUIT 1
+8 IF $PIECE(^AMHRINTK(I,0),U,6)=P
QUIT 1
+9 IF $PIECE(^AMHRINTK(I,0),U,13)=P
QUIT 1
+10 IF $PIECE(^AMHRINTK(I,0),U,4)=""
QUIT 1
+11 SET R=0
SET G=0
FOR
SET R=$ORDER(^AMHRINTK("AI",I,R))
IF R'=+R
QUIT
Begin DoDot:1
+12 IF $PIECE(^AMHRINTK(R,0),U,4)=P
SET G=1
+13 IF $PIECE(^AMHRINTK(R,0),U,6)=P
SET G=1
+14 IF $PIECE(^AMHRINTK(R,0),U,13)=P
SET G=1
End DoDot:1
+15 QUIT G
EDIT ;
+1 SET AMHRINTI=""
+2 DO EN^VALM2(XQORNOD(0),"OS")
+3 IF '$DATA(VALMY)
WRITE !,"No records selected."
GOTO EXIT
+4 SET AMHR1=$ORDER(VALMY(0))
IF 'AMHR1
KILL AMHR1,VALMY,XQORNOD
WRITE !,"No record selected."
GOTO EXIT
+5 SET (X,Y)=0
FOR
SET X=$ORDER(AMHINTK("IDX",X))
IF X'=+X!(AMHRINTI)
QUIT
IF $ORDER(AMHINTK("IDX",X,0))=AMHR1
SET Y=$ORDER(AMHINTK("IDX",X,0))
SET AMHRINTI=AMHINTK("IDX",X,Y)
+6 IF '$DATA(^AMHRINTK(AMHRINTI,0))
WRITE !,"Not a valid BH INTAKE."
DO PAUSE^AMHLEA
DO EXIT
QUIT
+7 IF $PIECE(^AMHRINTK(AMHRINTI,0),U,9)'="I"
WRITE !!,"This is not an Initial Intake. Use option U to edit an Update to",!,"an Intake document."
DO PAUSE^AMHLEA
DO EXIT
QUIT
+8 DO FULL^VALM1
+9 IF $PIECE(^AMHRINTK(AMHRINTI,0),U,11)
WRITE !!,"This Initial Intake document has been signed. You cannot edit it."
DO PAUSE^AMHLEA
DO EXIT
QUIT
+10 ;I $P(^AMHRINTK(AMHRINTI,0),U,3)'=AMHR D Q
+11 ;.W !!,"This Intake is not associated with the visit your are currently processing.",!,"To edit this Intake document you must use Edit Visit and edit the visit",!,"on "_$$VAL^XBDIQ1(9002011.13,AMHRINTI,.03),"." D PAUSE^AMHLEA,EXIT Q
+12 IF $$VALI^XBDIQ1(9002011.13,AMHRINTI,.04)'=DUZ&(DUZ'=$$VALI^XBDIQ1(9002011.13,AMHRINTI,.13))&(DUZ'=$$VALI^XBDIQ1(9002011.13,AMHRINTI,.06))
Begin DoDot:1
+13 WRITE !,"You are not the original provider or the person who entered or ",!,"modified this document. You cannot edit it."
End DoDot:1
DO PAUSE^AMHLEA
DO EXIT
QUIT
+14 SET DA=AMHRINTI
SET DIE="^AMHRINTK("
SET DR=".01"_$SELECT('$ORDER(^AMHRINTK("AI",AMHRINTI,0)):";.05",1:"")_";.04;.06////^S X=DUZ;.07//^S X=DT"_";4100"
DO ^DIE
KILL DIE,DR,DA
+15 ;I '$O(^AMHRINTK("AI",AMHRINTI,0)) S DIE="^AMHRINTK(",DA=AMHRINTI,DR=".05" D ^DIE K DIE,DA,DR
+16 ;S DIE="^AMHRINTK(",DA=AMHRINTI,DR=".04;.06////^S X=DUZ;.07//^S X=DT"_";4100" D ^DIE K DIE,DR,DA
+17 ;set visit multiple, .07
+18 ;S DA=AMHRINTI,DIE="^AMHRINTK(",DR=".07////"_DT,DIE("NO^")="" D ^DIE K DIE,DA,DR
+19 ;S DA=AMHRINTI,DIE="^AMHRINTK(",DR=4100,DIE("NO^")="" D ^DIE
+20 WRITE !!,"Initial Intake document updated...."
DO SIGNINT(AMHRINTI)
DO PAUSE^AMHLEA
+21 DO EXIT
+22 QUIT
PRINT ;
+1 SET AMHRINTI=""
+2 DO EN^VALM2(XQORNOD(0),"OS")
+3 IF '$DATA(VALMY)
WRITE !,"No records selected."
GOTO EXIT
+4 SET AMHR1=$ORDER(VALMY(0))
IF 'AMHR1
KILL AMHR1,VALMY,XQORNOD
WRITE !,"No record selected."
GOTO EXIT
+5 SET (X,Y)=0
FOR
SET X=$ORDER(AMHINTK("IDX",X))
IF X'=+X!(AMHRINTI)
QUIT
IF $ORDER(AMHINTK("IDX",X,0))=AMHR1
SET Y=$ORDER(AMHINTK("IDX",X,0))
SET AMHRINTI=AMHINTK("IDX",X,Y)
+6 IF '$DATA(^AMHRINTK(AMHRINTI,0))
WRITE !,"Not a valid BH INTAKE."
DO PAUSE^AMHLEA
DO EXIT
QUIT
+7 DO FULL^VALM1
+8 DO PRINT^AMHLEIV3
+9 DO PAUSE^AMHLEA
+10 DO EXIT
+11 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ;EP -- exit code
+1 KILL AMHX,AMHINTK,AMHPC,AMHR1
+2 DO TERM^VALM0
+3 SET VALMBCK="R"
+4 DO GATHER
+5 SET VALMCNT=AMHLINE
+6 DO HDR
+7 KILL X,Y,Z,I
+8 QUIT
+9 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
DEL ;EP - called from protocol entry
+1 NEW AMHY,AMHRINTI,AMHX,AMHZ,AMHC,AMHC1,AMHRINT,AMHRIU
+2 DO FULL^VALM1
+3 IF '$DATA(^XUSEC("AMHZ DELETE RECORD",DUZ))
IF '$DATA(^AMHSITE(DUZ(2),21,"B",DUZ))
WRITE !!,"You do not have the security access to delete an Intake document.",!,"Please see your supervisor or program manager.",!
DO PAUSE^AMHLEA
DO EXIT
QUIT
+4 SET AMHRINTI=""
+5 DO EN^VALM2(XQORNOD(0),"OS")
+6 IF '$DATA(VALMY)
WRITE !,"No records selected."
GOTO EXIT
+7 SET AMHR1=$ORDER(VALMY(0))
IF 'AMHR1
KILL AMHR1,VALMY,XQORNOD
WRITE !,"No record selected."
GOTO EXIT
+8 SET (X,Y)=0
FOR
SET X=$ORDER(AMHINTK("IDX",X))
IF X'=+X!(AMHRINTI)
QUIT
IF $ORDER(AMHINTK("IDX",X,0))=AMHR1
SET Y=$ORDER(AMHINTK("IDX",X,0))
SET AMHRINTI=AMHINTK("IDX",X,Y)
+9 IF '$DATA(^AMHRINTK(AMHRINTI,0))
WRITE !,"Not a valid BH INTAKE."
DO PAUSE^AMHLEA
DO EXIT
QUIT
DEL1 ;are you sure??
+1 KILL AMHY
+2 IF '$DATA(^AMHRINTK(AMHRINTI))
DO EXIT
QUIT
+3 SET AMHY(1)=AMHRINTI
SET AMHC=1
+4 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRINTK("AI",AMHRINTI,AMHX))
IF AMHX'=+AMHX
QUIT
SET AMHC=AMHC+1
SET AMHY(AMHC)=AMHX
+5 WRITE !!,"You can now select which Intake or Update document to delete. Initial Intake ",!,"documents that have Updates associated with them cannot be deleted.",!
+6 WRITE !?5,"0",?10,"Quit/Exit"
+7 SET X=0
SET AMHC=0
FOR
SET AMHC=$ORDER(AMHY(AMHC))
IF AMHC'=+AMHC
QUIT
SET AMHX=AMHY(AMHC)
Begin DoDot:1
+8 SET AMHINTR=$PIECE(^AMHRINTK(AMHX,0),U,3)
+9 SET AMHC1=AMHC
WRITE !?5,AMHC,?10,"Date: ",$$D($$VALI^XBDIQ1(9002011.13,AMHX,.01))," Provider: ",$EXTRACT($$VAL^XBDIQ1(9002011.13,AMHX,.04),1,15),?51,$EXTRACT($$VAL^XBDIQ1(9002011.13,AMHX,.05),1,13),?65,$$VAL^XBDIQ1(9002011.13,AMHX,.09)
End DoDot:1
+10 WRITE !
+11 SET DIR(0)="N^0:"_AMHC1_":0"
SET DIR("A")="Select Action"
SET DIR("B")="0"
KILL DA
DO ^DIR
KILL DIR
+12 IF $DATA(DIRUT)
DO EXIT
QUIT
+13 IF Y=0
DO EXIT
QUIT
+14 SET AMHRINT=AMHY(Y)
+15 SET AMHRIU=$PIECE(^AMHRINTK(AMHRINT,0),U,9)
+16 IF $DATA(^AMHSITE(DUZ(2),21,"B",DUZ))
GOTO DISP
+17 IF $PIECE(^AMHRINTK(AMHRINT,0),U,4)'=DUZ&(DUZ'=$PIECE(^AMHRINTK(AMHRINT,0),U,13))&(DUZ'=$PIECE(^AMHRINTK(AMHRINT,0),U,6))
Begin DoDot:1
+18 WRITE !!,"You are not the provider or the person who entered this "_$SELECT(AMHRIU="I":"Initial Intake",1:"Update"),!,"document, you cannot delete it."
End DoDot:1
DO PAUSE^AMHLEA
GOTO DEL1
+19 IF $PIECE(^AMHRINTK(AMHRINT,0),U,11)
IF '$DATA(^XUSEC("AMHZ DELETE SIGNED NOTE",DUZ))
Begin DoDot:1
+20 WRITE !!,"You cannot delete this "_$SELECT(AMHRIU="I":"Initial Intake",1:"Update")_" document, it has been electronically signed.",!,"Please see your supervisor or program manager."
DO PAUSE^AMHLEA
QUIT
End DoDot:1
GOTO DEL1
DISP ;
+1 IF $PIECE(^AMHRINTK(AMHRINT,0),U,9)="I"
IF $DATA(^AMHRINTK("AI",AMHRINT))
WRITE !!,"This Initial Intake has Updates associated with it, it cannot be deleted."
DO PAUSE^AMHLEA
GOTO DEL1
+2 SET DA=AMHRINT
SET DIC="^AMHRINTK("
DO EN^DIQ
+3 ;LORI
SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete this "_$SELECT(AMHRIU="I":"Initial Intake",1:"Update")_" document"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+4 IF 'Y
WRITE !!,$SELECT(AMHRIU="I":"Initial Intake",1:"Update")_" document not deleted."
DO PAUSE^AMHLEA
GOTO DEL1
+5 SET DA=AMHRINT
SET DIK="^AMHRINTK("
DO ^DIK
+6 KILL DA,DIK
+7 ;
+8 WRITE !!,$SELECT(AMHRIU="I":"Initial Intake",1:"Update")_" document deleted."
DO PAUSE^AMHLEA
+9 GOTO DEL1
+10 QUIT
UPD ;
+1 NEW AMHR1,X,AMHRINTI,AMHX,AMHY,AMHC,AMHA,AMHRINTU
+2 SET AMHRINTI=""
+3 DO EN^VALM2(XQORNOD(0),"OS")
+4 IF '$DATA(VALMY)
WRITE !,"No records selected."
GOTO EXIT
+5 SET AMHR1=$ORDER(VALMY(0))
IF 'AMHR1
KILL AMHR1,VALMY,XQORNOD
WRITE !,"No record selected."
GOTO EXIT
+6 SET (X,Y)=0
FOR
SET X=$ORDER(AMHINTK("IDX",X))
IF X'=+X!(AMHRINTI)
QUIT
IF $ORDER(AMHINTK("IDX",X,0))=AMHR1
SET Y=$ORDER(AMHINTK("IDX",X,0))
SET AMHRINTI=AMHINTK("IDX",X,Y)
+7 IF '$DATA(^AMHRINTK(AMHRINTI,0))
WRITE !,"Not a valid BH INTAKE."
DO PAUSE^AMHLEA
DO EXIT
QUIT
+8 ;I $P(^AMHRINTK(AMHRINTI,0),U,9)'="I" W !!,"This is not an Initial Intake. Use option U to edit an update to",!,"an intake document." D PAUSE^AMHLEA,EXIT Q
+9 DO FULL^VALM1
+10 ;I $P(^AMHRINTK(AMHRINTI,0),U,11) W !!,"This intake document has been signed. You cannot edit it." D PAUSE^AMHLEA,EXIT Q
+11 ;display all updates for this initial intake
UPD1 ;
+1 KILL AMHY
+2 SET AMHC=0
SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRINTK("AI",AMHRINTI,AMHX))
IF AMHX'=+AMHX
QUIT
SET AMHC=AMHC+1
SET AMHY(AMHC)=AMHX
+3 SET AMHA=AMHC+1
+4 WRITE !!,"You can either add a new Update to this Intake document or edit an "
+5 WRITE !,"existing, unsigned one on which you are the provider. Please select an Update"
+6 WRITE !,"to edit or choose ",AMHA," to add a new one or 0 to quit.",!
+7 WRITE !?5,"0",?10,"Quit/Exit Update"
+8 SET X=0
SET AMHC=0
FOR
SET AMHC=$ORDER(AMHY(AMHC))
IF AMHC'=+AMHC
QUIT
SET AMHX=AMHY(AMHC)
Begin DoDot:1
+9 ;S AMHINTR=$P(^AMHRINTK(AMHX,0),U,3)
+10 WRITE !?5,AMHC,?10,"Date Updated: ",$$D($$VALI^XBDIQ1(9002011.13,AMHX,.01))," Provider: ",$EXTRACT($$VAL^XBDIQ1(9002011.13,AMHX,.04),1,20),?66,$EXTRACT($$VAL^XBDIQ1(9002011.13,AMHX,.05),1,13)
End DoDot:1
+11 WRITE !?5,AMHA,?10,"Add new Update document",!
+12 SET DIR(0)="N^0:"_AMHA_":0"
SET DIR("A")="Select Action"
SET DIR("B")="0"
KILL DA
DO ^DIR
KILL DIR
+13 IF $DATA(DIRUT)
DO EXIT
QUIT
+14 IF Y=AMHA
DO ADDUPD
DO PAUSE^AMHLEA
GOTO UPD1
+15 IF Y=0
DO EXIT
QUIT
+16 SET AMHRINTU=AMHY(Y)
UPDE ;
+1 IF $PIECE(^AMHRINTK(AMHRINTU,0),U,11)
WRITE !!,"This Intake Update document has been signed. You cannot edit it."
DO PAUSE^AMHLEA
GOTO UPD1
+2 ;I $P(^AMHRINTK(AMHRINTI,0),U,3)'=AMHR D Q
+3 ;.W !!,"This Update document is not associated with the visit your are currently processing.",!,"To edit this Update document you must use Edit Visit and edit the visit",!,"on "_$$VAL^XBDIQ1(9002011.13,AMHRINTI,.03),"." D PAUSE^AMHLEA,EXIT Q
+4 IF $$VALI^XBDIQ1(9002011.13,AMHRINTU,.04)'=DUZ&(DUZ'=$PIECE(^AMHRINTK(AMHRINTU,0),U,13))&(DUZ'=$$VALI^XBDIQ1(9002011.13,AMHRINTU,.06))
Begin DoDot:1
+5 WRITE !,"You are not the original provider or the person who entered/edited this ",!,"document. You cannot edit it."
End DoDot:1
DO PAUSE^AMHLEA
GOTO UPD1
+6 SET DA=AMHRINTU
SET DIE="^AMHRINTK("
SET DR=".01;.04;.06////^S X=DUZ;.07////"_DT_";.07;4100"
DO ^DIE
KILL DIE,DR,DA
+7 ;set visit multiple, .07
+8 ;S DA=AMHRINTI,DIE="^AMHRINTK(",DR=".07////"_DT,DIE("NO^")="" D ^DIE K DIE,DA,DR
+9 ;S DA=AMHRINTI,DIE="^AMHRINTK(",DR=4100,DIE("NO^")="" D ^DIE
+10 WRITE !!,"Intake Update document updated...."
DO SIGNINT(AMHRINTU)
DO PAUSE^AMHLEA
GOTO UPD1
+11 QUIT
ADDUPD ;
+1 DO FULL^VALM1
+2 SET AMHIDAT=""
+3 IF $GET(AMHR)
SET AMHIDAT=$PIECE($PIECE(^AMHREC(AMHR,0),U),".")
+4 IF AMHIDAT=""
SET AMHIDAT=$PIECE($GET(AMHDATE),".",1)
+5 IF AMHIDAT=""
SET AMHIDAT=DT
+6 ;," with a date of ",$$FMTE^XLFDT(AMHIDAT),"."
WRITE !,"Adding Intake Update for ",$$VAL^XBDIQ1(2,AMHPAT,.01)
+7 SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue on to add the Intake Update"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
DO PAUSE^AMHLEA
DO EXIT
QUIT
+9 IF 'Y
DO PAUSE^AMHLEA
DO EXIT
QUIT
+10 ;create and update
+11 SET X=AMHIDAT
SET DIC(0)="L"
SET DIC="^AMHRINTK("
SET DLAYGO=9002011.13
SET DIADD=1
SET DIC("DR")=".02////"_AMHPAT_";.05///"_$$VAL^XBDIQ1(9002011.13,AMHRINTI,.05)_";.07////"_DT_";.09///U;.13////"_DUZ_";.1////"_AMHRINTI
+12 KILL DD,D0,DO
+13 DO FILE^DICN
+14 KILL DIC,DLAYGO,DIADD
+15 IF Y=-1
WRITE !!,"Error creating Update to the Intake document...."
QUIT
+16 SET AMHRINTU=+Y
+17 ;update 11 multiple and .07
+18 SET AMHPROVN=$SELECT($GET(AMHR):$$PRIMPROV^AMHUTIL(AMHR,"N"),1:$PIECE(^VA(200,DUZ,0),U,1))
+19 SET DA=AMHRINTU
SET DIE="^AMHRINTK("
SET DR=".01;.04//"_AMHPROVN_";.07;4100"
SET DIE("NO^")=""
DO ^DIE
KILL DIE,DA
+20 SET DA=AMHRINTU
SET DIE="^AMHRINTK("
SET DR=".06////"_DUZ
SET DIE("NO^")=""
DO ^DIE
KILL DA,DIE,DR
+21 WRITE !!,"Intake Update document created..."
DO SIGNINT(AMHRINTU)
+22 QUIT
