Routine: AMHGEGP

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)")

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)

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"

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))

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

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")

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))

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

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)

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))

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

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))

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

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)")

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

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)")

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

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       ;

AMHGEGP.m