AMHGEGP ; IHS/CMI/MAW - AMHG Save Group Encounter 3/8/2009 7:41:21 PM ;
;;4.0;IHS BEHAVIORAL HEALTH;**2,4,5**;JUN 02, 2010;Build 18
;
;
;
DEBUG(RETVAL,AMHSTR) ;replace tag below to allow Serenji debug of GUI
D DEBUG^%Serenji("TAG^AMHGU(.AMHRET,.AMHSTR)")
Q
;
POV(D,RC,P,A2) ;EP -- add/modify pov
N AMHDA,R
S R="~"
S AMHDA=0 F S AMHDA=$O(A2(AMHDA)) Q:'AMHDA D
. N STR,PIEN,PCODE,PNARR
. S STR=$G(A2(AMHDA))
. S PIEN=$P(STR,R)
. S PCODE=$P(STR,R,2)
. S PNARR=$P(STR,R,3)
. I $G(PNARR)]"" D
..S AMHN=$$FNDNARR^AMHGU(PNARR,1)
. I D="A" D ADDPOV^AMHGEVF(PIEN,P,RC,AMHN) Q
. I D="E" D Q
.. N AMHPREC
.. S AMHPREC=$$FNDPOV^AMHGU(PIEN,RC)
.. I 'AMHPREC D ADDPOV^AMHGEVF(PIEN,P,RC,AMHN) Q
.. D EDITPOV^AMHGEVF(AMHPREC,AMHN)
I D="E" D Q
. D DELPOV^AMHGEVF(RC,.A2)
Q
;
GP(AMHIEN,DM,REC,PRG,GN,CL,NS,TOC,EL,ED,CS,ACT,AT,CC) ;EP -- group add/edit
N AMHFDA,AMHIENS,AMHERRR,FL
S AMHIENS=$S(DM="A":"+1,",1:REC_",")
S FL=9002011.67
S AMHFDA(FL,AMHIENS,.01)=ED
S AMHFDA(FL,AMHIENS,.02)=PRG
S AMHFDA(FL,AMHIENS,.03)=GN
S AMHFDA(FL,AMHIENS,.05)=EL
S AMHFDA(FL,AMHIENS,.14)=CL
I DM="A" D ;v4.0p2 ihs/cmi/maw added
. S AMHFDA(FL,AMHIENS,.06)=CS
. S AMHFDA(FL,AMHIENS,.07)=ACT
. S AMHFDA(FL,AMHIENS,.08)=TOC
. S AMHFDA(FL,AMHIENS,.11)=AT
. S AMHFDA(FL,AMHIENS,.13)=DT
. S AMHFDA(FL,AMHIENS,.15)=DUZ
. S AMHFDA(FL,AMHIENS,1200)=CC
I DM="A" D
. ;S AMHFDA(FL,AMHIENS,.01)=ED
. S AMHFDA(FL,AMHIENS,.04)=DT
. S AMHFDA(FL,AMHIENS,.12)=DUZ
. D UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
. I '$D(AMHERRR) S AMHIEN=$G(AMHIENS(1)) Q
. S AMHER="0~Add Group"
I DM="E" D
. D FILE^DIE("K","AMHFDA","AMHERRR(1)")
. I $D(AMHERRR) S AMHER="0~Edit Group"
Q
;
MODPRV(P,D,RC,PAT,TYP) ;EP -- modify the provider based on data mode
N AMHFDA,AMHIENS,AMHERRR,AMHPIEN
S AMHIENS="+2,"_RC_","
S AMHFDA(9002011.6711,AMHIENS,.01)=P
S AMHFDA(9002011.6711,AMHIENS,.02)=TYP
D UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
I $D(AMHERRR) S AMHER="0~Add "_$G(TYP)_" Provider"
S AMHPIEN=$G(AMHIENS(2))
Q
;
CLNPRV(RC) ;EP -- clean out provider multiple
S DA(1)=RC
S DIK="^AMHGROUP("_DA(1)_",11,"
N PDA
S PDA=0 F S PDA=$O(^AMHGROUP(RC,11,PDA)) Q:'PDA D
. S DA=PDA D ^DIK
Q
;
SP(D,RC,P,SP) ;EP -- file secondary providers from activity tab
N ASP
D ARRAY^AMHGU(.ASP,.SP)
N AMHDA
S AMHDA=0 F S AMHDA=$O(ASP(AMHDA)) Q:'AMHDA D
. N PRV
. S PRV=+$G(ASP(AMHDA))
. D MODPRV(PRV,D,RC,P,"S")
Q
;
GPOV(D,RC,PV) ;EP -- file the purpose of visit
D CLNPV(RC)
N PVDA,R
S R="~"
S PVDA=0 F S PVDA=$O(PV(PVDA)) Q:'PVDA D
. N PVSTR,PVI,PVN,AMHN
. S PVSTR=$G(PV(PVDA))
. S PVI=$P(PVSTR,R)
. S PVN=$P(PVSTR,R,3)
. I $G(PVN)]"" D
.. S AMHN=$$FNDNARR^AMHGU(PVN,1)
. N AMHFDA,AMHIENS,AMHERRR,FL
. S AMHIENS="+2,"_RC_","
. S FL=9002011.6721
. S AMHFDA(FL,AMHIENS,.01)=PVI
. S AMHFDA(FL,AMHIENS,.02)=$G(AMHN)
. D UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
. I $D(AMHERRR) S AMHER="0~Add Group POV" Q
. S AMHPVIEN=$G(AMHIENS(2))
Q
;
CLNPV(RC) ;EP -- clean the pov multiple out first
S DA(1)=RC
S DIK="^AMHGROUP("_DA(1)_",21,"
N PDA
S PDA=0 F S PDA=$O(^AMHGROUP(RC,21,PDA)) Q:'PDA D
. S DA=PDA D ^DIK
Q
;
PN(D,RC,PN,P) ;EP -- file the progress notes
Q:$G(PN)=""
N AMHWP
D ARRAYT^AMHGU(.AMHWP,PN) ;parse the text into an array
N AMHFDA,AMHIENS,AMHERRR
S AMHIENS=RC_","
D WP^AMHGU(.AMHERRR,9002011.67,AMHIENS,3101,.AMHWP)
Q
;
CPT(RC,CI) ;EP -- add a cpt
D CLNCPT(RC)
N CDA,R
S R="~"
S CDA=0 F S CDA=$O(CI(CDA)) Q:'CDA D
. N CSTR,CIEN,CQTY,CMOD1,CMOD2
. S CSTR=$G(CI(CDA))
. S CIEN=$P(CSTR,R)
. S CQTY=$P(CSTR,R,4)
. I CQTY<1 S CQTY=1
. S CMOD1=$P(CSTR,R,5)
. S CMOD2=$P(CSTR,R,6)
. N AMHFDA,AMHIENS,AMHERRR
. S AMHIENS="+2,"_RC_","
. S AMHFDA(9002011.6741,AMHIENS,.01)=CIEN
. S AMHFDA(9002011.6741,AMHIENS,.02)=CQTY
. S AMHFDA(9002011.6741,AMHIENS,.03)=CMOD1
. S AMHFDA(9002011.6741,AMHIENS,.04)=CMOD2
. D UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
. I $D(AMHERRR) S AMHER="0~Add Activity CPT" Q
. S AMHCIEN=$G(AMHIENS(2))
Q
;
CLNCPT(RC) ;EP -- clean cpt multiple
S DA(1)=RC
S DIK="^AMHGROUP("_DA(1)_",41,"
N CDA
S CDA=0 F S CDA=$O(^AMHGROUP(RC,41,CDA)) Q:'CDA D
. S DA=CDA D ^DIK
Q
;
EDU(RC,EDU) ;EP -- file the education topics
D CLNEDU(RC)
N EDA,R
S R="~"
S EDA=0 F S EDA=$O(EDU(EDA)) Q:'EDA D
. N ESTR,ED,L,LOU,CM,CP,ST,G,PR
. S ESTR=$G(EDU(EDA))
. S ED=$P(ESTR,R)
. I ED]"" S ED=$O(^AUTTEDT("B",ED,0)) ;get internal value to file
. S L=$P(ESTR,R,2)
. S LOU=$$SCI^AMHGT(9002011.05,.08,$P(ESTR,R,3))
. S CM=$P(ESTR,R,4)
. S CP=$P(ESTR,R,5)
. I $G(CP)]"" S CP=$O(^ICPT("B",CP,0))
. S ST=$$SCI^AMHGT(9002011.05,.11,$P(ESTR,R,6))
. S G=$P(ESTR,R,7)
. S PR=$S($P(ESTR,R,8):$P(ESTR,R,8),1:DUZ)
. N AMHFDA,AMHIENS,AMHERRR
. S AMHIENS="+2,"_RC_","
. S AMHFDA(9002011.6771,AMHIENS,.01)=ED
. S AMHFDA(9002011.6771,AMHIENS,.02)=PR
. S AMHFDA(9002011.6771,AMHIENS,.03)="G"
. S AMHFDA(9002011.6771,AMHIENS,.04)=L
. S AMHFDA(9002011.6771,AMHIENS,.05)=CP
. S AMHFDA(9002011.6771,AMHIENS,.06)=LOU
. S AMHFDA(9002011.6771,AMHIENS,.07)=G
. S AMHFDA(9002011.6771,AMHIENS,.08)=ST
. S AMHFDA(9002011.6771,AMHIENS,1101)=CM
. D UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
. I $D(AMHERRR) S AMHER="0~Add Education Topic" Q
. S AMHEIEN=$G(AMHIENS(2))
Q
;
CLNEDU(RC) ;EP -- clean the edu topic multiple
S DA(1)=RC
S DIK="^AMHGROUP("_DA(1)_",71,"
N EDA
S EDA=0 F S EDA=$O(^AMHGROUP(RC,71,EDA)) Q:'EDA D
. S DA=EDA D ^DIK
Q
;
PATS(RC,PTS) ;EP -- add patients to multiple
D CLNPAT(RC)
N PTDA
S PTDA=0 F S PTDA=$O(PTS(PTDA)) Q:'PTDA D
. N PAT
. S PAT=$G(PTS(PTDA))
. N AMHFDA,AMHIENS,AMHERRR
. S AMHIENS="+2,"_RC_","
. S AMHFDA(9002011.6751,AMHIENS,.01)=PAT
. D UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
Q
;
CLNPAT(RC) ;EP -- clean out the patient multiple
S DA(1)=RC
S DIK="^AMHGROUP("_DA(1)_",51,"
N PDA
S PDA=0 F S PDA=$O(^AMHGROUP(RC,51,PDA)) Q:'PDA D
. S DA=PDA D ^DIK
Q
;
MH(RC,MHR) ;EP -- add mhss recs to multiple
D CLNMH(RC)
N MHDA
S MHDA=0 F S MHDA=$O(MHR(MHDA)) Q:'MHDA D
. N MHI
. S MHI=$G(MHR(MHDA))
. N AMHFDA,AMHIENS,AMHERRR
. S AMHIENS="+2,"_RC_","
. S AMHFDA(9002011.6761,AMHIENS,.01)=MHI
. D UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
Q
;
CLNMH(RC) ;EP -- clean out mental health
S DA(1)=RC
S DIK="^AMHGROUP("_DA(1)_",61,"
N MDA
S MDA=0 F S MDA=$O(^AMHGROUP(RC,61,MDA)) Q:'MDA D
. S DA=MDA D ^DIK
Q
;
AMHGEGP ; IHS/CMI/MAW - AMHG Save Group Encounter 3/8/2009 7:41:21 PM ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**2,4,5**;JUN 02, 2010;Build 18
+2 ;
+3 ;
+4 ;
DEBUG(RETVAL,AMHSTR) ;replace tag below to allow Serenji debug of GUI
+1 DO DEBUG^%Serenji("TAG^AMHGU(.AMHRET,.AMHSTR)")
+2 QUIT
+3 ;
POV(D,RC,P,A2) ;EP -- add/modify pov
+1 NEW AMHDA,R
+2 SET R="~"
+3 SET AMHDA=0
FOR
SET AMHDA=$ORDER(A2(AMHDA))
IF 'AMHDA
QUIT
Begin DoDot:1
+4 NEW STR,PIEN,PCODE,PNARR
+5 SET STR=$GET(A2(AMHDA))
+6 SET PIEN=$PIECE(STR,R)
+7 SET PCODE=$PIECE(STR,R,2)
+8 SET PNARR=$PIECE(STR,R,3)
+9 IF $GET(PNARR)]""
Begin DoDot:2
+10 SET AMHN=$$FNDNARR^AMHGU(PNARR,1)
End DoDot:2
+11 IF D="A"
DO ADDPOV^AMHGEVF(PIEN,P,RC,AMHN)
QUIT
+12 IF D="E"
Begin DoDot:2
+13 NEW AMHPREC
+14 SET AMHPREC=$$FNDPOV^AMHGU(PIEN,RC)
+15 IF 'AMHPREC
DO ADDPOV^AMHGEVF(PIEN,P,RC,AMHN)
QUIT
+16 DO EDITPOV^AMHGEVF(AMHPREC,AMHN)
End DoDot:2
QUIT
End DoDot:1
+17 IF D="E"
Begin DoDot:1
+18 DO DELPOV^AMHGEVF(RC,.A2)
End DoDot:1
QUIT
+19 QUIT
+20 ;
GP(AMHIEN,DM,REC,PRG,GN,CL,NS,TOC,EL,ED,CS,ACT,AT,CC) ;EP -- group add/edit
+1 NEW AMHFDA,AMHIENS,AMHERRR,FL
+2 SET AMHIENS=$SELECT(DM="A":"+1,",1:REC_",")
+3 SET FL=9002011.67
+4 SET AMHFDA(FL,AMHIENS,.01)=ED
+5 SET AMHFDA(FL,AMHIENS,.02)=PRG
+6 SET AMHFDA(FL,AMHIENS,.03)=GN
+7 SET AMHFDA(FL,AMHIENS,.05)=EL
+8 SET AMHFDA(FL,AMHIENS,.14)=CL
+9 ;v4.0p2 ihs/cmi/maw added
IF DM="A"
Begin DoDot:1
+10 SET AMHFDA(FL,AMHIENS,.06)=CS
+11 SET AMHFDA(FL,AMHIENS,.07)=ACT
+12 SET AMHFDA(FL,AMHIENS,.08)=TOC
+13 SET AMHFDA(FL,AMHIENS,.11)=AT
+14 SET AMHFDA(FL,AMHIENS,.13)=DT
+15 SET AMHFDA(FL,AMHIENS,.15)=DUZ
+16 SET AMHFDA(FL,AMHIENS,1200)=CC
End DoDot:1
+17 IF DM="A"
Begin DoDot:1
+18 ;S AMHFDA(FL,AMHIENS,.01)=ED
+19 SET AMHFDA(FL,AMHIENS,.04)=DT
+20 SET AMHFDA(FL,AMHIENS,.12)=DUZ
+21 DO UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
+22 IF '$DATA(AMHERRR)
SET AMHIEN=$GET(AMHIENS(1))
QUIT
+23 SET AMHER="0~Add Group"
End DoDot:1
+24 IF DM="E"
Begin DoDot:1
+25 DO FILE^DIE("K","AMHFDA","AMHERRR(1)")
+26 IF $DATA(AMHERRR)
SET AMHER="0~Edit Group"
End DoDot:1
+27 QUIT
+28 ;
MODPRV(P,D,RC,PAT,TYP) ;EP -- modify the provider based on data mode
+1 NEW AMHFDA,AMHIENS,AMHERRR,AMHPIEN
+2 SET AMHIENS="+2,"_RC_","
+3 SET AMHFDA(9002011.6711,AMHIENS,.01)=P
+4 SET AMHFDA(9002011.6711,AMHIENS,.02)=TYP
+5 DO UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
+6 IF $DATA(AMHERRR)
SET AMHER="0~Add "_$GET(TYP)_" Provider"
+7 SET AMHPIEN=$GET(AMHIENS(2))
+8 QUIT
+9 ;
CLNPRV(RC) ;EP -- clean out provider multiple
+1 SET DA(1)=RC
+2 SET DIK="^AMHGROUP("_DA(1)_",11,"
+3 NEW PDA
+4 SET PDA=0
FOR
SET PDA=$ORDER(^AMHGROUP(RC,11,PDA))
IF 'PDA
QUIT
Begin DoDot:1
+5 SET DA=PDA
DO ^DIK
End DoDot:1
+6 QUIT
+7 ;
SP(D,RC,P,SP) ;EP -- file secondary providers from activity tab
+1 NEW ASP
+2 DO ARRAY^AMHGU(.ASP,.SP)
+3 NEW AMHDA
+4 SET AMHDA=0
FOR
SET AMHDA=$ORDER(ASP(AMHDA))
IF 'AMHDA
QUIT
Begin DoDot:1
+5 NEW PRV
+6 SET PRV=+$GET(ASP(AMHDA))
+7 DO MODPRV(PRV,D,RC,P,"S")
End DoDot:1
+8 QUIT
+9 ;
GPOV(D,RC,PV) ;EP -- file the purpose of visit
+1 DO CLNPV(RC)
+2 NEW PVDA,R
+3 SET R="~"
+4 SET PVDA=0
FOR
SET PVDA=$ORDER(PV(PVDA))
IF 'PVDA
QUIT
Begin DoDot:1
+5 NEW PVSTR,PVI,PVN,AMHN
+6 SET PVSTR=$GET(PV(PVDA))
+7 SET PVI=$PIECE(PVSTR,R)
+8 SET PVN=$PIECE(PVSTR,R,3)
+9 IF $GET(PVN)]""
Begin DoDot:2
+10 SET AMHN=$$FNDNARR^AMHGU(PVN,1)
End DoDot:2
+11 NEW AMHFDA,AMHIENS,AMHERRR,FL
+12 SET AMHIENS="+2,"_RC_","
+13 SET FL=9002011.6721
+14 SET AMHFDA(FL,AMHIENS,.01)=PVI
+15 SET AMHFDA(FL,AMHIENS,.02)=$GET(AMHN)
+16 DO UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
+17 IF $DATA(AMHERRR)
SET AMHER="0~Add Group POV"
QUIT
+18 SET AMHPVIEN=$GET(AMHIENS(2))
End DoDot:1
+19 QUIT
+20 ;
CLNPV(RC) ;EP -- clean the pov multiple out first
+1 SET DA(1)=RC
+2 SET DIK="^AMHGROUP("_DA(1)_",21,"
+3 NEW PDA
+4 SET PDA=0
FOR
SET PDA=$ORDER(^AMHGROUP(RC,21,PDA))
IF 'PDA
QUIT
Begin DoDot:1
+5 SET DA=PDA
DO ^DIK
End DoDot:1
+6 QUIT
+7 ;
PN(D,RC,PN,P) ;EP -- file the progress notes
+1 IF $GET(PN)=""
QUIT
+2 NEW AMHWP
+3 ;parse the text into an array
DO ARRAYT^AMHGU(.AMHWP,PN)
+4 NEW AMHFDA,AMHIENS,AMHERRR
+5 SET AMHIENS=RC_","
+6 DO WP^AMHGU(.AMHERRR,9002011.67,AMHIENS,3101,.AMHWP)
+7 QUIT
+8 ;
CPT(RC,CI) ;EP -- add a cpt
+1 DO CLNCPT(RC)
+2 NEW CDA,R
+3 SET R="~"
+4 SET CDA=0
FOR
SET CDA=$ORDER(CI(CDA))
IF 'CDA
QUIT
Begin DoDot:1
+5 NEW CSTR,CIEN,CQTY,CMOD1,CMOD2
+6 SET CSTR=$GET(CI(CDA))
+7 SET CIEN=$PIECE(CSTR,R)
+8 SET CQTY=$PIECE(CSTR,R,4)
+9 IF CQTY<1
SET CQTY=1
+10 SET CMOD1=$PIECE(CSTR,R,5)
+11 SET CMOD2=$PIECE(CSTR,R,6)
+12 NEW AMHFDA,AMHIENS,AMHERRR
+13 SET AMHIENS="+2,"_RC_","
+14 SET AMHFDA(9002011.6741,AMHIENS,.01)=CIEN
+15 SET AMHFDA(9002011.6741,AMHIENS,.02)=CQTY
+16 SET AMHFDA(9002011.6741,AMHIENS,.03)=CMOD1
+17 SET AMHFDA(9002011.6741,AMHIENS,.04)=CMOD2
+18 DO UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
+19 IF $DATA(AMHERRR)
SET AMHER="0~Add Activity CPT"
QUIT
+20 SET AMHCIEN=$GET(AMHIENS(2))
End DoDot:1
+21 QUIT
+22 ;
CLNCPT(RC) ;EP -- clean cpt multiple
+1 SET DA(1)=RC
+2 SET DIK="^AMHGROUP("_DA(1)_",41,"
+3 NEW CDA
+4 SET CDA=0
FOR
SET CDA=$ORDER(^AMHGROUP(RC,41,CDA))
IF 'CDA
QUIT
Begin DoDot:1
+5 SET DA=CDA
DO ^DIK
End DoDot:1
+6 QUIT
+7 ;
EDU(RC,EDU) ;EP -- file the education topics
+1 DO CLNEDU(RC)
+2 NEW EDA,R
+3 SET R="~"
+4 SET EDA=0
FOR
SET EDA=$ORDER(EDU(EDA))
IF 'EDA
QUIT
Begin DoDot:1
+5 NEW ESTR,ED,L,LOU,CM,CP,ST,G,PR
+6 SET ESTR=$GET(EDU(EDA))
+7 SET ED=$PIECE(ESTR,R)
+8 ;get internal value to file
IF ED]""
SET ED=$ORDER(^AUTTEDT("B",ED,0))
+9 SET L=$PIECE(ESTR,R,2)
+10 SET LOU=$$SCI^AMHGT(9002011.05,.08,$PIECE(ESTR,R,3))
+11 SET CM=$PIECE(ESTR,R,4)
+12 SET CP=$PIECE(ESTR,R,5)
+13 IF $GET(CP)]""
SET CP=$ORDER(^ICPT("B",CP,0))
+14 SET ST=$$SCI^AMHGT(9002011.05,.11,$PIECE(ESTR,R,6))
+15 SET G=$PIECE(ESTR,R,7)
+16 SET PR=$SELECT($PIECE(ESTR,R,8):$PIECE(ESTR,R,8),1:DUZ)
+17 NEW AMHFDA,AMHIENS,AMHERRR
+18 SET AMHIENS="+2,"_RC_","
+19 SET AMHFDA(9002011.6771,AMHIENS,.01)=ED
+20 SET AMHFDA(9002011.6771,AMHIENS,.02)=PR
+21 SET AMHFDA(9002011.6771,AMHIENS,.03)="G"
+22 SET AMHFDA(9002011.6771,AMHIENS,.04)=L
+23 SET AMHFDA(9002011.6771,AMHIENS,.05)=CP
+24 SET AMHFDA(9002011.6771,AMHIENS,.06)=LOU
+25 SET AMHFDA(9002011.6771,AMHIENS,.07)=G
+26 SET AMHFDA(9002011.6771,AMHIENS,.08)=ST
+27 SET AMHFDA(9002011.6771,AMHIENS,1101)=CM
+28 DO UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
+29 IF $DATA(AMHERRR)
SET AMHER="0~Add Education Topic"
QUIT
+30 SET AMHEIEN=$GET(AMHIENS(2))
End DoDot:1
+31 QUIT
+32 ;
CLNEDU(RC) ;EP -- clean the edu topic multiple
+1 SET DA(1)=RC
+2 SET DIK="^AMHGROUP("_DA(1)_",71,"
+3 NEW EDA
+4 SET EDA=0
FOR
SET EDA=$ORDER(^AMHGROUP(RC,71,EDA))
IF 'EDA
QUIT
Begin DoDot:1
+5 SET DA=EDA
DO ^DIK
End DoDot:1
+6 QUIT
+7 ;
PATS(RC,PTS) ;EP -- add patients to multiple
+1 DO CLNPAT(RC)
+2 NEW PTDA
+3 SET PTDA=0
FOR
SET PTDA=$ORDER(PTS(PTDA))
IF 'PTDA
QUIT
Begin DoDot:1
+4 NEW PAT
+5 SET PAT=$GET(PTS(PTDA))
+6 NEW AMHFDA,AMHIENS,AMHERRR
+7 SET AMHIENS="+2,"_RC_","
+8 SET AMHFDA(9002011.6751,AMHIENS,.01)=PAT
+9 DO UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
End DoDot:1
+10 QUIT
+11 ;
CLNPAT(RC) ;EP -- clean out the patient multiple
+1 SET DA(1)=RC
+2 SET DIK="^AMHGROUP("_DA(1)_",51,"
+3 NEW PDA
+4 SET PDA=0
FOR
SET PDA=$ORDER(^AMHGROUP(RC,51,PDA))
IF 'PDA
QUIT
Begin DoDot:1
+5 SET DA=PDA
DO ^DIK
End DoDot:1
+6 QUIT
+7 ;
MH(RC,MHR) ;EP -- add mhss recs to multiple
+1 DO CLNMH(RC)
+2 NEW MHDA
+3 SET MHDA=0
FOR
SET MHDA=$ORDER(MHR(MHDA))
IF 'MHDA
QUIT
Begin DoDot:1
+4 NEW MHI
+5 SET MHI=$GET(MHR(MHDA))
+6 NEW AMHFDA,AMHIENS,AMHERRR
+7 SET AMHIENS="+2,"_RC_","
+8 SET AMHFDA(9002011.6761,AMHIENS,.01)=MHI
+9 DO UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
End DoDot:1
+10 QUIT
+11 ;
CLNMH(RC) ;EP -- clean out mental health
+1 SET DA(1)=RC
+2 SET DIK="^AMHGROUP("_DA(1)_",61,"
+3 NEW MDA
+4 SET MDA=0
FOR
SET MDA=$ORDER(^AMHGROUP(RC,61,MDA))
IF 'MDA
QUIT
Begin DoDot:1
+5 SET DA=MDA
DO ^DIK
End DoDot:1
+6 QUIT
+7 ;
