AMHEGR ; IHS/CMI/LAB - GROUP ENTRY ;
;;4.0;IHS BEHAVIORAL HEALTH;**2,4,5,8**;JUN 02, 2010;Build 7
;
;
START ;
W:$D(IOF) @IOF
D DONE
;
DATES ;
K AMHRED,AMHRBD
W !,"Please enter the date range for displaying Group definitions."
K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Date"
D ^DIR Q:Y<1 S AMHRBD=Y
K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Date"
D ^DIR Q:Y<1 S AMHRED=Y
;
I AMHRED<AMHRBD D G DATES
. W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
;
D EN,FULL^VALM1
D DONE
Q
DONE ;
D EN^XBVK("AMH")
D ^XBFMK
D KILL^AUPNPAT
Q
EN ;
K ^TMP($J,"AMHEGR")
D ^AMHLEIN
D GATHER
D EN^VALM("AMH GROUP ENTRY")
D CLEAR^VALM1
Q
GATHER ;
D GATHER^AMHEGR1
Q
CTR(X,Y) ;EP - Center
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
HDR ; -- header code
S VALMHDR(1)="Group Entry * - Unsigned Group Note"
S X="",$E(X,7)="Date",$E(X,16)="Group Name",$E(X,37)="Activity",$E(X,48)="Prg",$E(X,52)="Cln",$E(X,59)="Prov",$E(X,69)="TOC",$E(X,73)="POV"
S VALMHDR(2)=X
Q
;
INIT ;
D GATHER
S VALMCNT=AMHLINE
Q
;
HELP ;
S X="?" D DISP^XQORM1 W !!
Q
;
EXPND ; -- expand code
Q
REV ;
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." D EXIT Q
S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT Q
S AMHNG=0 S AMHNG=^TMP($J,"AMHEGR","IDX",R,R)
I '$D(^AMHGROUP(AMHNG,0)) W !,"Not a valid GROUP." K AMHNG,R,AMHG,R1 D PAUSE D EXIT Q
D FULL^VALM1
I $P(^AMHGROUP(AMHNG,0),U,18) W !!,"The notes associated with this group entry have been signed. ",!,"You can edit other items in this entry but not the notes." D PAUSE
NEW P,X,G,A,R
K A
S P=0 F S P=$O(^AMHGROUP(AMHNG,61,P)) Q:P'=+P S R=$P(^AMHGROUP(AMHNG,61,P,0),U,1) S X=$P($G(^AMHREC(R,0)),U,8) S A(X)=""
S P=0,G=0 F S P=$O(^AMHGROUP(AMHNG,51,P)) Q:P'=+P S X=$P(^AMHGROUP(AMHNG,51,P,0),U) D
.I '$D(A(X)) S G=1
I G W !!,"All of the visits have not been entered for this group. Use Sign Note or ","Edit Group Definition to add visits.",! D PAUSE,EXIT Q
D ^AMHEGS
D EXIT
Q
EDITDEF ;
D FULL^VALM1
W !!,"This action should be used to edit a group definition only. If visits have"
W !,"already been entered for this group, you will not be able to edit the group"
W !,"definition.",!
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." D EXIT Q
S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT Q
S AMHNG=0 S AMHNG=^TMP($J,"AMHEGR","IDX",R,R)
I '$D(^AMHGROUP(AMHNG,0)) W !,"Not a valid GROUP." K AMHNG,R,AMHG,R1 D PAUSE D EXIT Q
D FULL^VALM1
I $O(^AMHGROUP(AMHNG,61,0)) W !!,"This group already has visits created. You must use the REVIEW/EDIT",!,"GROUP VISITS to modify visits within this group." D PAUSE,EXIT Q
I $P(^AMHGROUP(AMHNG,0),U,18) W !!,"This Group's Notes have been signed. You cannot edit the Group.",! D PAUSE,EXIT Q
S AMHDATE=$P($P(^AMHGROUP(AMHNG,0),U),".")
D EDITGRP
Q
ADDGRP ;
D FULL^VALM1
;add new group
K DIR S DIR(0)="D^:"_DT_":EP",DIR("A")="Enter Date of the Group Activity" KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !,"date not entered." D PAUSE,EXIT Q
S AMHDATE=Y
S X=AMHDATE,DIC="^AMHGROUP(",DLAYGO=9002011.67,DIADD=1,DIC(0)="L" K DD,DO D FILE^DICN
I Y=-1 W !!,"entry of new group failed." K DIADD,DLAYGO D ^XBFMK D EXIT Q
S AMHNG=+Y
K DIADD,DLAYGO D ^XBFMK
EDITGRP ;EP
S APCDOVRR=1
S DA=AMHNG,DDSFILE=9002011.67,DR="[AMH GROUP ADD/EDIT]" D ^DDS
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S AMHQUIT=1 K DIMSG D PAUSE,EXIT Q
;must have a pov/provider
S E=0
I '$O(^AMHGROUP(AMHNG,11,0)) W !!,"Group must have at least one Provider defined." S E=1
NEW X,G,C
S X=0,G=0,C=0 F S X=$O(^AMHGROUP(AMHNG,11,X)) Q:X'=+X I $P($G(^AMHGROUP(AMHNG,11,X,0)),U,2)="P" S G=1,C=C+1
I C>1 W !!,"Group must not have 2 PRIMARY PROVIDER's defined." S E=1
I 'G W !!,"Group must have at least one PRIMARY PROVIDER defined." S E=1
I '$O(^AMHGROUP(AMHNG,21,0)) W !!,"Group must have at least one POV defined." S E=1
I '$O(^AMHGROUP(AMHNG,51,0)) W !!,"Group must have at least one Patient defined." S E=1
S X=0,G=0 F S X=$O(^AMHGROUP(AMHNG,31,X)) Q:X'=+X I $G(^AMHGROUP(AMHNG,31,X,0))]"" S G=1
I 'G W !!,"Group must have a group narrative defined. " S E=1
I E S AMHE="" D G:AMHE="E" EDITGRP D:AMHE="Q" PAUSE,EXIT Q:AMHE="Q" W !!,"deleting group definition." S DA=AMHNG,DIK="^AMHGROUP(" D ^DIK D PAUSE,EXIT Q
.S DIR(0)="S^E:Edit the Group definition;D:Delete this Group definition;Q:to exit and edit it later without deleting the group definition",DIR("A")="This group definition is not complete, do you wish to",DIR("B")="E" KILL DA D ^DIR KILL DIR
.I $D(DIRUT) Q
.S AMHE=Y
.Q
;now loop through patients and add records
D ^XBFMK
W !!,"You have added the following group definition, please review it carefully",!,"before you proceed.",!
S DA=AMHNG,DIC="^AMHGROUP(" D EN^DIQ
S DIR(0)="S^Y:Yes, group definition is accurate, continue on to add visits;N:No, I wish to edit the group definition;Q:I wish to QUIT and exit",DIR("A")="Do you wish to continue on to add patient visits for this group"
S DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D PAUSE,EXIT Q
I Y="Q" D PAUSE,EXIT Q
I Y="N" G EDITGRP
SENS ;check for sensitive patients
S AMHQ=0
NEW AMHRESU
S AMHX=0 F S AMHX=$O(^AMHGROUP(AMHNG,51,AMHX)) Q:AMHX'=+AMHX!(AMHQ) D
.S AMHPAT=$P(^AMHGROUP(AMHNG,51,AMHX,0),U,1)
.K AMHRESU
.D PTSEC^AMHUTIL2(.AMHRESU,AMHPAT,1)
.I '$G(AMHRESU(1)) Q
.I $G(AMHRESU(1))=3!($G(AMHRESU(1))=4)!($G(AMHRESU(1))=5) D DISPDG^AMHLE S AMHQ=1 Q
.D DISPDG^AMHEGS
.W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to continue to add visits for this group",DIR("B")="N" KILL DA D ^DIR KILL DIR
.I 'Y S AMHQ=1 Q
.K AMHRESU
.D NOTICE^DGSEC4(.AMHRESU,AMHPAT,,3)
K AMHPAT
W !!!
I AMHQ D D EXIT Q
.W !!,"You have selected not to continue and add visits for a patient in this group."
.W !,"You must go back and remove the patient from the group definition before "
.W !,"you can continue on to add the visits for the group.",!!!!
.D PAUSE^AMHLEA
D ADDREC
D EXIT
Q
DUP ;EP -
D DUP^AMHEGR1
Q
DISP ;EP - called from protocol
D DISP^AMHEGR1
Q
PRTEF ;EP
D PRTEF^AMHEGR1
Q
DEL ;EP - called from protocol
D DEL^AMHEGR1
Q
ADDREC ;EP
D FULL^VALM1
K DIR
W !!,"Adding records for each individual patient in this group.",!
K AMHDELQ S AMHNGX=0 F S AMHNGX=$O(^AMHGROUP(AMHNG,51,AMHNGX)) Q:AMHNGX'=+AMHNGX!($G(AMHDELQ)) D ADDREC1
SIGN ;EP
S AMHSIGN=0
S P=$$PP(AMHNG)
I $D(^AMHSITE(DUZ(2),19,"B",P)) W !!,"No E-Sig Required. Provider opted out of E-Sig." G PCCLINK
S D=$P($P(^AMHGROUP(AMHNG,0),U),".")
I '$$ESIGREQ^AMHESIG(,D) W !!,"No E-Sig required. Date prior to Version 4.0." G PCCLINK
I P'=DUZ W !!,"You are not the primary provider for this group, no electronic",!,"signature will be applied and no PCC link will occur.",!,"The primary provider will need to sign these at a later time." D PAUSE,EXIT Q
W !!,"You can now sign all of the progress notes for this group of visits."
D SIG^XUSESIG
I X1="" W !!,"You will need to sign them later." K X1 D PAUSE,EXIT Q
S AMHSIGN=1
PCCLINK ;
D PCCLINK^AMHEGR1
K X1
SIGN1 D PAUSE,EXIT
Q
ADDREC1 ;EP
S (AMHPAT,DFN)=$P(^AMHGROUP(AMHNG,51,AMHNGX,0),U)
ADDREC2 ;
S AMHG0=^AMHGROUP(AMHNG,0)
S APCDOVRR=1,AMHOVRR=1
S AMHVTYPE="R",AMHLOC=$P(AMHG0,U,5),AMHPROG=$P(AMHG0,U,2),AMHDATE=$P(AMHG0,U),AMHCLN=$P(AMHG0,U,14),AMHCOMM=$P(AMHG0,U,6),AMHACT=$P(AMHG0,U,7),AMHCONT=$P(AMHG0,U,8),AMHINT="",AMHPTYPE=AMHPROG,AMHCC=$G(^AMHGROUP(AMHNG,12))
S AMHTIME=$P(AMHG0,U,11)
S AMHNUM=0,X=0 F S X=$O(^AMHGROUP(AMHNG,51,X)) Q:X'=+X S AMHNUM=AMHNUM+1
S AMHACTP=AMHTIME\AMHNUM I AMHACTP<1 S AMHACTP=1
S AMHACTN=1
W !!,"Creating new BH record for ",$P(^DPT(AMHPAT,0),U),"."
K DD,D0,DO,DIC,DA,DR S DIC("DR")="",DIC(0)="EL",DIC="^AMHREC(",DLAYGO=9002011,DIADD=1,X=AMHDATE,DIC("DR")="1111////1" D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0
I Y=-1 W !!,$C(7),$C(7),"Behavioral Health Record is NOT complete!! Deleting Record.",! D PAUSE,^XBFMK Q
S (DA,AMHR)=+Y,AMHAWIXX="A",DIE="^AMHREC(",DR="[AMH ADD RECORD NO INTERACT]" D CALLDIE^AMHLEIN K AMHAWIXX
I $D(Y) D S AMHDELQ=1 Q
.W !!,"ERROR -- Incomplete record!! You have exited before a complete record"
.W !,"had been added. I have to delete the record. Please complete the",!,"entry of patient visits for this group at a later time.",!!
.S AMHGRPDE=1 D DELR^AMHEGR1 K AMHGRPDE Q
S AMHVTYPE=$P(^AMHREC(AMHR,0),U,33)
K DIADD,DLAYGO
D ^XBFMK
S DIE="^AMHREC(",DA=AMHR
S DR=".09////1;.11////U;.19////"_DUZ_";.33////R;.28////"_DUZ_";.22///A;.21///^S X=DT;.25////"_$P(AMHNG,U,14)_";.34////1;.12////"_AMHACTP_";1109////"_$P(^AMHGROUP(AMHNG,0),U,3)_";1117////"_$$HL^AMHUTIL2($$VALI^XBDIQ1(9002011,AMHR,.02))
;_";2101///"_$P($G(^AMHGROUP(AMHNG,12)),U,1)
D ^DIE
I $D(Y) W !!,"updating record for patient ",$P(^DPT(DFN,0),U)," failed." D PAUSE,EXIT Q
S DIE="^AMHREC(",DA=AMHR,DR="5100///NOW",DR(2,9002011.5101)=".02////^S X=DUZ" D ^DIE K DIE,DA,DR
I $P($G(^AMHGROUP(AMHNG,12)),U,1)]"" S $P(^AMHREC(AMHR,21),U,1)=$P(^AMHGROUP(AMHNG,12),U,1)
;add in providers,povs,cpts,subjective
ADDPRV ;
S AMHP=0 F S AMHP=$O(^AMHGROUP(AMHNG,11,AMHP)) Q:AMHP'=+AMHP D
.S AMHP1=$P(^AMHGROUP(AMHNG,11,AMHP,0),U)
.Q:'AMHP1
.Q:'$D(^VA(200,AMHP1,0))
.S X=AMHP1,DIC("DR")=".02////"_$G(AMHPAT)_";.03////"_AMHR_";.04///"_$P(^AMHGROUP(AMHNG,11,AMHP,0),U,2),DIC="^AMHRPROV(",DIC(0)="MLQ",DIADD=1,DLAYGO=9002011.02 K DD,DO D FILE^DICN
.K DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
.I Y=-1 W !!,"Creating Provider entry failed!!!",$C(7),$C(7) H 2
ADDPOV ;
S AMHP=0 F S AMHP=$O(^AMHGROUP(AMHNG,21,AMHP)) Q:AMHP'=+AMHP D
.S AMHP1=$P(^AMHGROUP(AMHNG,21,AMHP,0),U)
.Q:'AMHP1
.Q:'$D(^AMHPROB(AMHP1,0))
.S AMHNAR=$P(^AMHGROUP(AMHNG,21,AMHP,0),U,2)
.S X=AMHP1,DIC("DR")=".02////"_$G(AMHPAT)_";.03////"_AMHR_";.04///`"_AMHNAR,DIC="^AMHRPRO(",DIC(0)="MLQ",DIADD=1,DLAYGO=9002011.01 K DD,DO D FILE^DICN
.K DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
.I Y=-1 W !!,"Creating POV entry failed!!!",$C(7),$C(7) H 2
D EP2^AMHEGRPV
I $G(AMHDELTV) D Q
.W !!,"ERROR -- Incomplete record!! Deleting record.",!!
.S AMHGRPDE=1 D DELR^AMHEGR1 K AMHGRPDE Q
ADDCPTS ;
S AMHP=0 F S AMHP=$O(^AMHGROUP(AMHNG,41,AMHP)) Q:AMHP'=+AMHP D
.S AMHP1=$P(^AMHGROUP(AMHNG,41,AMHP,0),U)
.Q:'AMHP1
.Q:'$D(^ICPT(AMHP1,0))
.S AMH0=^AMHGROUP(AMHNG,41,AMHP,0)
.S X=AMHP1,DIC("DR")=".02////"_$G(AMHPAT)_";.03////"_AMHR_";.08////"_$P(AMH0,U,3)_";.09////"_$P(AMH0,U,4)_";.16////"_$P(AMH0,U,2)
.S DIC="^AMHRPROC(",DIC(0)="MLQ",DIADD=1,DLAYGO=9002011.04 K DD,DO D FILE^DICN
.K DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
.I Y=-1 W !!,"Creating CPT entry failed!!!",$C(7),$C(7) H 2
ADDPTED ;
K DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
S AMHP=0 F S AMHP=$O(^AMHGROUP(AMHNG,71,AMHP)) Q:AMHP'=+AMHP D
.S AMHP1=$P(^AMHGROUP(AMHNG,71,AMHP,0),U)
.S AMHP0=^AMHGROUP(AMHNG,71,AMHP,0)
.S AMHP11=$P($G(^AMHGROUP(AMHNG,71,AMHP,11)),U)
.S AMHP12=$P($G(^AMHGROUP(AMHNG,71,AMHP,11)),U,2)
.Q:'AMHP1
.Q:'$D(^AUTTEDT(AMHP1,0))
.S X=AMHP1
.S DIC("DR")=".02////"_$G(AMHPAT)_";.03////"_AMHR_";.04///`"_$P(AMHP0,U,2)_";.05///"_$P(AMHP0,U,3)_";.06///"_$P(AMHP0,U,4)_";.07////"_$P(AMHP0,U,5)_";.08///"_$P(AMHP0,U,6)_";.09///"_$P(AMHP0,U,7)_";.11///"_$P(AMHP0,U,8)_";1102////"_AMHP12
.S DIC="^AMHREDU(",DIC(0)="MLQ",DIADD=1,DLAYGO=9002011.05 K DD,DO D FILE^DICN
.K DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
.I Y=-1 W !!,"Creating PT ED entry failed!!!",$C(7),$C(7) H 2
.I AMHP11]"" S $P(^AMHREDU(+Y,11),U,1)=AMHP11
CC ;
W !!
S DA=AMHR,DIE="^AMHREC(",DR=2101 D ^DIE K DA,DIE,DR D ^XBFMK
W !
SOAP ;put in standard soap
D SOAP^AMHEGR1
MCPT ;
D EP^AMHEGRCP
D ^XBFMK
W !
S DA=AMHR,DIE="^AMHREC(",DR=".27VISIT FLAG: " D ^DIE,^XBFMK
Q
PAUSE ;EP
K DIR
S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
EXIT ;EP -- exit code
D TERM^VALM0
S VALMBCK="R"
D GATHER
S VALMCNT=AMHLINE
D HDR
K X,Y,Z,I
Q
NOSHOW ;EP - CALLED FROM PROTOCOL
D FULL^VALM1
W !!,"This option is used to enter a No-Show visit for a client who failed"
W !,"to show for his/her group session."
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." D EXIT Q
S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT Q
S AMHG=0 S AMHG=^TMP($J,"AMHEGR","IDX",R,R)
I '$D(^AMHGROUP(AMHG,0)) W !,"Not a valid GROUP." K AMHRDEL,R,AMHG,R1 D PAUSE,EXIT Q
S AMHDATE=$P(^AMHGROUP(AMHG,0),U)
S AMHPTYPE=$P(^AMHGROUP(AMHG,0),U,2)
S AMHVTYPE="R"
S AMHPAT=""
D GETPAT^AMHLEA
I AMHPAT="" W !!,"No patient entered" H 2 D EXIT Q
S DFN=AMHPAT
D ADDNS
K AMHPAT,DFN,AMHDATE,AMHPTYPE,AMHVTYPE
D EXIT
Q
ADDNS ;EP
D ADDNS^AMHEGS
Q
INTX(X) ;
I '$D(^AUPNPAT(X)) Q 0
I '$$ALLOWP^AMHUTIL(DUZ,X) D NALLOWP^AMHUTIL Q 0
NEW %,D
S %=$$DOD^AUPNPAT(X) I %="" Q 0
S D=$S($G(AMHDATE):$P(AMHDATE,"."),$G(DA(1)):$P(^AMHGROUP(DA(1),0),U,1))
I $G(D),$P(D,".")>% K X Q 0
Q 1
ALIVE ;EP
I '$D(X) Q
NEW %,D
S %=$$DOD^AUPNPAT(X) I %="" Q
S D=$S($G(AMHDATE):$P(AMHDATE,"."),$G(DA(1)):$P(^AMHGROUP(DA(1),0),U,1))
I $G(D),$P(D,".")>% K X D EN^DDIOL("Patient is deceased as of the visit date.") K X Q
Q
PP(G) ;EP
NEW X,Y
S Y=""
S X=0 F S X=$O(^AMHGROUP(G,11,X)) Q:X'=+X I $P(^AMHGROUP(G,11,X,0),U,2)="P" S Y=$P(^AMHGROUP(G,11,X,0),U,1)
Q Y
AMHEGR ; IHS/CMI/LAB - GROUP ENTRY ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**2,4,5,8**;JUN 02, 2010;Build 7
+2 ;
+3 ;
START ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 DO DONE
+3 ;
DATES ;
+1 KILL AMHRED,AMHRBD
+2 WRITE !,"Please enter the date range for displaying Group definitions."
+3 KILL DIR
WRITE !
SET DIR(0)="DO^::EXP"
SET DIR("A")="Enter Beginning Date"
+4 DO ^DIR
IF Y<1
QUIT
SET AMHRBD=Y
+5 KILL DIR
SET DIR(0)="DO^:DT:EXP"
SET DIR("A")="Enter Ending Date"
+6 DO ^DIR
IF Y<1
QUIT
SET AMHRED=Y
+7 ;
+8 IF AMHRED<AMHRBD
Begin DoDot:1
+9 WRITE !!,$CHAR(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
End DoDot:1
GOTO DATES
+10 ;
+11 DO EN
DO FULL^VALM1
+12 DO DONE
+13 QUIT
DONE ;
+1 DO EN^XBVK("AMH")
+2 DO ^XBFMK
+3 DO KILL^AUPNPAT
+4 QUIT
EN ;
+1 KILL ^TMP($JOB,"AMHEGR")
+2 DO ^AMHLEIN
+3 DO GATHER
+4 DO EN^VALM("AMH GROUP ENTRY")
+5 DO CLEAR^VALM1
+6 QUIT
GATHER ;
+1 DO GATHER^AMHEGR1
+2 QUIT
CTR(X,Y) ;EP - Center
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
HDR ; -- header code
+1 SET VALMHDR(1)="Group Entry * - Unsigned Group Note"
+2 SET X=""
SET $EXTRACT(X,7)="Date"
SET $EXTRACT(X,16)="Group Name"
SET $EXTRACT(X,37)="Activity"
SET $EXTRACT(X,48)="Prg"
SET $EXTRACT(X,52)="Cln"
SET $EXTRACT(X,59)="Prov"
SET $EXTRACT(X,69)="TOC"
SET $EXTRACT(X,73)="POV"
+3 SET VALMHDR(2)=X
+4 QUIT
+5 ;
INIT ;
+1 DO GATHER
+2 SET VALMCNT=AMHLINE
+3 QUIT
+4 ;
HELP ;
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
REV ;
+1 DO EN^VALM2(XQORNOD(0),"OS")
+2 IF '$DATA(VALMY)
WRITE !,"No records selected."
DO EXIT
QUIT
+3 SET R=$ORDER(VALMY(0))
IF 'R
KILL R,VALMY,XQORNOD
WRITE !,"No record selected."
DO EXIT
QUIT
+4 SET AMHNG=0
SET AMHNG=^TMP($JOB,"AMHEGR","IDX",R,R)
+5 IF '$DATA(^AMHGROUP(AMHNG,0))
WRITE !,"Not a valid GROUP."
KILL AMHNG,R,AMHG,R1
DO PAUSE
DO EXIT
QUIT
+6 DO FULL^VALM1
+7 IF $PIECE(^AMHGROUP(AMHNG,0),U,18)
WRITE !!,"The notes associated with this group entry have been signed. ",!,"You can edit other items in this entry but not the notes."
DO PAUSE
+8 NEW P,X,G,A,R
+9 KILL A
+10 SET P=0
FOR
SET P=$ORDER(^AMHGROUP(AMHNG,61,P))
IF P'=+P
QUIT
SET R=$PIECE(^AMHGROUP(AMHNG,61,P,0),U,1)
SET X=$PIECE($GET(^AMHREC(R,0)),U,8)
SET A(X)=""
+11 SET P=0
SET G=0
FOR
SET P=$ORDER(^AMHGROUP(AMHNG,51,P))
IF P'=+P
QUIT
SET X=$PIECE(^AMHGROUP(AMHNG,51,P,0),U)
Begin DoDot:1
+12 IF '$DATA(A(X))
SET G=1
End DoDot:1
+13 IF G
WRITE !!,"All of the visits have not been entered for this group. Use Sign Note or ","Edit Group Definition to add visits.",!
DO PAUSE
DO EXIT
QUIT
+14 DO ^AMHEGS
+15 DO EXIT
+16 QUIT
EDITDEF ;
+1 DO FULL^VALM1
+2 WRITE !!,"This action should be used to edit a group definition only. If visits have"
+3 WRITE !,"already been entered for this group, you will not be able to edit the group"
+4 WRITE !,"definition.",!
+5 DO EN^VALM2(XQORNOD(0),"OS")
+6 IF '$DATA(VALMY)
WRITE !,"No records selected."
DO EXIT
QUIT
+7 SET R=$ORDER(VALMY(0))
IF 'R
KILL R,VALMY,XQORNOD
WRITE !,"No record selected."
DO EXIT
QUIT
+8 SET AMHNG=0
SET AMHNG=^TMP($JOB,"AMHEGR","IDX",R,R)
+9 IF '$DATA(^AMHGROUP(AMHNG,0))
WRITE !,"Not a valid GROUP."
KILL AMHNG,R,AMHG,R1
DO PAUSE
DO EXIT
QUIT
+10 DO FULL^VALM1
+11 IF $ORDER(^AMHGROUP(AMHNG,61,0))
WRITE !!,"This group already has visits created. You must use the REVIEW/EDIT",!,"GROUP VISITS to modify visits within this group."
DO PAUSE
DO EXIT
QUIT
+12 IF $PIECE(^AMHGROUP(AMHNG,0),U,18)
WRITE !!,"This Group's Notes have been signed. You cannot edit the Group.",!
DO PAUSE
DO EXIT
QUIT
+13 SET AMHDATE=$PIECE($PIECE(^AMHGROUP(AMHNG,0),U),".")
+14 DO EDITGRP
+15 QUIT
ADDGRP ;
+1 DO FULL^VALM1
+2 ;add new group
+3 KILL DIR
SET DIR(0)="D^:"_DT_":EP"
SET DIR("A")="Enter Date of the Group Activity"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
WRITE !,"date not entered."
DO PAUSE
DO EXIT
QUIT
+5 SET AMHDATE=Y
+6 SET X=AMHDATE
SET DIC="^AMHGROUP("
SET DLAYGO=9002011.67
SET DIADD=1
SET DIC(0)="L"
KILL DD,DO
DO FILE^DICN
+7 IF Y=-1
WRITE !!,"entry of new group failed."
KILL DIADD,DLAYGO
DO ^XBFMK
DO EXIT
QUIT
+8 SET AMHNG=+Y
+9 KILL DIADD,DLAYGO
DO ^XBFMK
EDITGRP ;EP
+1 SET APCDOVRR=1
+2 SET DA=AMHNG
SET DDSFILE=9002011.67
SET DR="[AMH GROUP ADD/EDIT]"
DO ^DDS
+3 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
SET AMHQUIT=1
KILL DIMSG
DO PAUSE
DO EXIT
QUIT
+4 ;must have a pov/provider
+5 SET E=0
+6 IF '$ORDER(^AMHGROUP(AMHNG,11,0))
WRITE !!,"Group must have at least one Provider defined."
SET E=1
+7 NEW X,G,C
+8 SET X=0
SET G=0
SET C=0
FOR
SET X=$ORDER(^AMHGROUP(AMHNG,11,X))
IF X'=+X
QUIT
IF $PIECE($GET(^AMHGROUP(AMHNG,11,X,0)),U,2)="P"
SET G=1
SET C=C+1
+9 IF C>1
WRITE !!,"Group must not have 2 PRIMARY PROVIDER's defined."
SET E=1
+10 IF 'G
WRITE !!,"Group must have at least one PRIMARY PROVIDER defined."
SET E=1
+11 IF '$ORDER(^AMHGROUP(AMHNG,21,0))
WRITE !!,"Group must have at least one POV defined."
SET E=1
+12 IF '$ORDER(^AMHGROUP(AMHNG,51,0))
WRITE !!,"Group must have at least one Patient defined."
SET E=1
+13 SET X=0
SET G=0
FOR
SET X=$ORDER(^AMHGROUP(AMHNG,31,X))
IF X'=+X
QUIT
IF $GET(^AMHGROUP(AMHNG,31,X,0))]""
SET G=1
+14 IF 'G
WRITE !!,"Group must have a group narrative defined. "
SET E=1
+15 IF E
SET AMHE=""
Begin DoDot:1
+16 SET DIR(0)="S^E:Edit the Group definition;D:Delete this Group definition;Q:to exit and edit it later without deleting the group definition"
SET DIR("A")="This group definition is not complete, do you wish to"
SET DIR("B")="E"
KILL DA
DO ^DIR
KILL DIR
+17 IF $DATA(DIRUT)
QUIT
+18 SET AMHE=Y
+19 QUIT
End DoDot:1
IF AMHE="E"
GOTO EDITGRP
IF AMHE="Q"
DO PAUSE
DO EXIT
IF AMHE="Q"
QUIT
WRITE !!,"deleting group definition."
SET DA=AMHNG
SET DIK="^AMHGROUP("
DO ^DIK
DO PAUSE
DO EXIT
QUIT
+20 ;now loop through patients and add records
+21 DO ^XBFMK
+22 WRITE !!,"You have added the following group definition, please review it carefully",!,"before you proceed.",!
+23 SET DA=AMHNG
SET DIC="^AMHGROUP("
DO EN^DIQ
+24 SET DIR(0)="S^Y:Yes, group definition is accurate, continue on to add visits;N:No, I wish to edit the group definition;Q:I wish to QUIT and exit"
SET DIR("A")="Do you wish to continue on to add patient visits for this group"
+25 SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+26 IF $DATA(DIRUT)
DO PAUSE
DO EXIT
QUIT
+27 IF Y="Q"
DO PAUSE
DO EXIT
QUIT
+28 IF Y="N"
GOTO EDITGRP
SENS ;check for sensitive patients
+1 SET AMHQ=0
+2 NEW AMHRESU
+3 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHGROUP(AMHNG,51,AMHX))
IF AMHX'=+AMHX!(AMHQ)
QUIT
Begin DoDot:1
+4 SET AMHPAT=$PIECE(^AMHGROUP(AMHNG,51,AMHX,0),U,1)
+5 KILL AMHRESU
+6 DO PTSEC^AMHUTIL2(.AMHRESU,AMHPAT,1)
+7 IF '$GET(AMHRESU(1))
QUIT
+8 IF $GET(AMHRESU(1))=3!($GET(AMHRESU(1))=4)!($GET(AMHRESU(1))=5)
DO DISPDG^AMHLE
SET AMHQ=1
QUIT
+9 DO DISPDG^AMHEGS
+10 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you want to continue to add visits for this group"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+11 IF 'Y
SET AMHQ=1
QUIT
+12 KILL AMHRESU
+13 DO NOTICE^DGSEC4(.AMHRESU,AMHPAT,,3)
End DoDot:1
+14 KILL AMHPAT
+15 WRITE !!!
+16 IF AMHQ
Begin DoDot:1
+17 WRITE !!,"You have selected not to continue and add visits for a patient in this group."
+18 WRITE !,"You must go back and remove the patient from the group definition before "
+19 WRITE !,"you can continue on to add the visits for the group.",!!!!
+20 DO PAUSE^AMHLEA
End DoDot:1
DO EXIT
QUIT
+21 DO ADDREC
+22 DO EXIT
+23 QUIT
DUP ;EP -
+1 DO DUP^AMHEGR1
+2 QUIT
DISP ;EP - called from protocol
+1 DO DISP^AMHEGR1
+2 QUIT
PRTEF ;EP
+1 DO PRTEF^AMHEGR1
+2 QUIT
DEL ;EP - called from protocol
+1 DO DEL^AMHEGR1
+2 QUIT
ADDREC ;EP
+1 DO FULL^VALM1
+2 KILL DIR
+3 WRITE !!,"Adding records for each individual patient in this group.",!
+4 KILL AMHDELQ
SET AMHNGX=0
FOR
SET AMHNGX=$ORDER(^AMHGROUP(AMHNG,51,AMHNGX))
IF AMHNGX'=+AMHNGX!($GET(AMHDELQ))
QUIT
DO ADDREC1
SIGN ;EP
+1 SET AMHSIGN=0
+2 SET P=$$PP(AMHNG)
+3 IF $DATA(^AMHSITE(DUZ(2),19,"B",P))
WRITE !!,"No E-Sig Required. Provider opted out of E-Sig."
GOTO PCCLINK
+4 SET D=$PIECE($PIECE(^AMHGROUP(AMHNG,0),U),".")
+5 IF '$$ESIGREQ^AMHESIG(,D)
WRITE !!,"No E-Sig required. Date prior to Version 4.0."
GOTO PCCLINK
+6 IF P'=DUZ
WRITE !!,"You are not the primary provider for this group, no electronic",!,"signature will be applied and no PCC link will occur.",!,"The primary provider will need to sign these at a later time."
DO PAUSE
DO EXIT
QUIT
+7 WRITE !!,"You can now sign all of the progress notes for this group of visits."
+8 DO SIG^XUSESIG
+9 IF X1=""
WRITE !!,"You will need to sign them later."
KILL X1
DO PAUSE
DO EXIT
QUIT
+10 SET AMHSIGN=1
PCCLINK ;
+1 DO PCCLINK^AMHEGR1
+2 KILL X1
SIGN1 DO PAUSE
DO EXIT
+1 QUIT
ADDREC1 ;EP
+1 SET (AMHPAT,DFN)=$PIECE(^AMHGROUP(AMHNG,51,AMHNGX,0),U)
ADDREC2 ;
+1 SET AMHG0=^AMHGROUP(AMHNG,0)
+2 SET APCDOVRR=1
SET AMHOVRR=1
+3 SET AMHVTYPE="R"
SET AMHLOC=$PIECE(AMHG0,U,5)
SET AMHPROG=$PIECE(AMHG0,U,2)
SET AMHDATE=$PIECE(AMHG0,U)
SET AMHCLN=$PIECE(AMHG0,U,14)
SET AMHCOMM=$PIECE(AMHG0,U,6)
SET AMHACT=$PIECE(AMHG0,U,7)
SET AMHCONT=$PIECE(AMHG0,U,8)
SET AMHINT=""
SET AMHPTYPE=AMHPROG
SET AMHCC=$GET(^AMHGROUP(AMHNG,12))
+4 SET AMHTIME=$PIECE(AMHG0,U,11)
+5 SET AMHNUM=0
SET X=0
FOR
SET X=$ORDER(^AMHGROUP(AMHNG,51,X))
IF X'=+X
QUIT
SET AMHNUM=AMHNUM+1
+6 SET AMHACTP=AMHTIME\AMHNUM
IF AMHACTP<1
SET AMHACTP=1
+7 SET AMHACTN=1
+8 WRITE !!,"Creating new BH record for ",$PIECE(^DPT(AMHPAT,0),U),"."
+9 KILL DD,D0,DO,DIC,DA,DR
SET DIC("DR")=""
SET DIC(0)="EL"
SET DIC="^AMHREC("
SET DLAYGO=9002011
SET DIADD=1
SET X=AMHDATE
SET DIC("DR")="1111////1"
DO FILE^DICN
KILL DIC,DR,DIE,DIADD,DLAYGO,X,D0
+10 IF Y=-1
WRITE !!,$CHAR(7),$CHAR(7),"Behavioral Health Record is NOT complete!! Deleting Record.",!
DO PAUSE
DO ^XBFMK
QUIT
+11 SET (DA,AMHR)=+Y
SET AMHAWIXX="A"
SET DIE="^AMHREC("
SET DR="[AMH ADD RECORD NO INTERACT]"
DO CALLDIE^AMHLEIN
KILL AMHAWIXX
+12 IF $DATA(Y)
Begin DoDot:1
+13 WRITE !!,"ERROR -- Incomplete record!! You have exited before a complete record"
+14 WRITE !,"had been added. I have to delete the record. Please complete the",!,"entry of patient visits for this group at a later time.",!!
+15 SET AMHGRPDE=1
DO DELR^AMHEGR1
KILL AMHGRPDE
QUIT
End DoDot:1
SET AMHDELQ=1
QUIT
+16 SET AMHVTYPE=$PIECE(^AMHREC(AMHR,0),U,33)
+17 KILL DIADD,DLAYGO
+18 DO ^XBFMK
+19 SET DIE="^AMHREC("
SET DA=AMHR
+20 SET DR=".09////1;.11////U;.19////"_DUZ_";.33////R;.28////"_DUZ_";.22///A;.21///^S X=DT;.25////"_$PIECE(AMHNG,U,14)_";.34////1;.12////"_AMHACTP_";1109////"_$PIECE(^AMHGROUP(AMHNG,0),U,3)_";1117////"_$$HL^AMHUTIL2($$VALI^XBDIQ1(9002011,AMHR,.02))
+21 ;_";2101///"_$P($G(^AMHGROUP(AMHNG,12)),U,1)
+22 DO ^DIE
+23 IF $DATA(Y)
WRITE !!,"updating record for patient ",$PIECE(^DPT(DFN,0),U)," failed."
DO PAUSE
DO EXIT
QUIT
+24 SET DIE="^AMHREC("
SET DA=AMHR
SET DR="5100///NOW"
SET DR(2,9002011.5101)=".02////^S X=DUZ"
DO ^DIE
KILL DIE,DA,DR
+25 IF $PIECE($GET(^AMHGROUP(AMHNG,12)),U,1)]""
SET $PIECE(^AMHREC(AMHR,21),U,1)=$PIECE(^AMHGROUP(AMHNG,12),U,1)
+26 ;add in providers,povs,cpts,subjective
ADDPRV ;
+1 SET AMHP=0
FOR
SET AMHP=$ORDER(^AMHGROUP(AMHNG,11,AMHP))
IF AMHP'=+AMHP
QUIT
Begin DoDot:1
+2 SET AMHP1=$PIECE(^AMHGROUP(AMHNG,11,AMHP,0),U)
+3 IF 'AMHP1
QUIT
+4 IF '$DATA(^VA(200,AMHP1,0))
QUIT
+5 SET X=AMHP1
SET DIC("DR")=".02////"_$GET(AMHPAT)_";.03////"_AMHR_";.04///"_$PIECE(^AMHGROUP(AMHNG,11,AMHP,0),U,2)
SET DIC="^AMHRPROV("
SET DIC(0)="MLQ"
SET DIADD=1
SET DLAYGO=9002011.02
KILL DD,DO
DO FILE^DICN
+6 KILL DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
+7 IF Y=-1
WRITE !!,"Creating Provider entry failed!!!",$CHAR(7),$CHAR(7)
HANG 2
End DoDot:1
ADDPOV ;
+1 SET AMHP=0
FOR
SET AMHP=$ORDER(^AMHGROUP(AMHNG,21,AMHP))
IF AMHP'=+AMHP
QUIT
Begin DoDot:1
+2 SET AMHP1=$PIECE(^AMHGROUP(AMHNG,21,AMHP,0),U)
+3 IF 'AMHP1
QUIT
+4 IF '$DATA(^AMHPROB(AMHP1,0))
QUIT
+5 SET AMHNAR=$PIECE(^AMHGROUP(AMHNG,21,AMHP,0),U,2)
+6 SET X=AMHP1
SET DIC("DR")=".02////"_$GET(AMHPAT)_";.03////"_AMHR_";.04///`"_AMHNAR
SET DIC="^AMHRPRO("
SET DIC(0)="MLQ"
SET DIADD=1
SET DLAYGO=9002011.01
KILL DD,DO
DO FILE^DICN
+7 KILL DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
+8 IF Y=-1
WRITE !!,"Creating POV entry failed!!!",$CHAR(7),$CHAR(7)
HANG 2
End DoDot:1
+9 DO EP2^AMHEGRPV
+10 IF $GET(AMHDELTV)
Begin DoDot:1
+11 WRITE !!,"ERROR -- Incomplete record!! Deleting record.",!!
+12 SET AMHGRPDE=1
DO DELR^AMHEGR1
KILL AMHGRPDE
QUIT
End DoDot:1
QUIT
ADDCPTS ;
+1 SET AMHP=0
FOR
SET AMHP=$ORDER(^AMHGROUP(AMHNG,41,AMHP))
IF AMHP'=+AMHP
QUIT
Begin DoDot:1
+2 SET AMHP1=$PIECE(^AMHGROUP(AMHNG,41,AMHP,0),U)
+3 IF 'AMHP1
QUIT
+4 IF '$DATA(^ICPT(AMHP1,0))
QUIT
+5 SET AMH0=^AMHGROUP(AMHNG,41,AMHP,0)
+6 SET X=AMHP1
SET DIC("DR")=".02////"_$GET(AMHPAT)_";.03////"_AMHR_";.08////"_$PIECE(AMH0,U,3)_";.09////"_$PIECE(AMH0,U,4)_";.16////"_$PIECE(AMH0,U,2)
+7 SET DIC="^AMHRPROC("
SET DIC(0)="MLQ"
SET DIADD=1
SET DLAYGO=9002011.04
KILL DD,DO
DO FILE^DICN
+8 KILL DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
+9 IF Y=-1
WRITE !!,"Creating CPT entry failed!!!",$CHAR(7),$CHAR(7)
HANG 2
End DoDot:1
ADDPTED ;
+1 KILL DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
+2 SET AMHP=0
FOR
SET AMHP=$ORDER(^AMHGROUP(AMHNG,71,AMHP))
IF AMHP'=+AMHP
QUIT
Begin DoDot:1
+3 SET AMHP1=$PIECE(^AMHGROUP(AMHNG,71,AMHP,0),U)
+4 SET AMHP0=^AMHGROUP(AMHNG,71,AMHP,0)
+5 SET AMHP11=$PIECE($GET(^AMHGROUP(AMHNG,71,AMHP,11)),U)
+6 SET AMHP12=$PIECE($GET(^AMHGROUP(AMHNG,71,AMHP,11)),U,2)
+7 IF 'AMHP1
QUIT
+8 IF '$DATA(^AUTTEDT(AMHP1,0))
QUIT
+9 SET X=AMHP1
+10 SET DIC("DR")=".02////"_$GET(AMHPAT)_";.03////"_AMHR_";.04///`"_$PIECE(AMHP0,U,2)_";.05///"_$PIECE(AMHP0,U,3)_";.06///"_$PIECE(AMHP0,U,4)_";.07////"_...
... $PIECE(AMHP0,U,5)_";.08///"_$PIECE(AMHP0,U,6)_";.09///"_$PIECE(AMHP0,U,7)_";.11///"_$PIECE(AMHP0,U,8)_";1102////"_AMHP12
+11 SET DIC="^AMHREDU("
SET DIC(0)="MLQ"
SET DIADD=1
SET DLAYGO=9002011.05
KILL DD,DO
DO FILE^DICN
+12 KILL DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
+13 IF Y=-1
WRITE !!,"Creating PT ED entry failed!!!",$CHAR(7),$CHAR(7)
HANG 2
+14 IF AMHP11]""
SET $PIECE(^AMHREDU(+Y,11),U,1)=AMHP11
End DoDot:1
CC ;
+1 WRITE !!
+2 SET DA=AMHR
SET DIE="^AMHREC("
SET DR=2101
DO ^DIE
KILL DA,DIE,DR
DO ^XBFMK
+3 WRITE !
SOAP ;put in standard soap
+1 DO SOAP^AMHEGR1
MCPT ;
+1 DO EP^AMHEGRCP
+2 DO ^XBFMK
+3 WRITE !
+4 SET DA=AMHR
SET DIE="^AMHREC("
SET DR=".27VISIT FLAG: "
DO ^DIE
DO ^XBFMK
+5 QUIT
PAUSE ;EP
+1 KILL DIR
+2 SET DIR(0)="EO"
SET DIR("A")="Press enter to continue...."
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 QUIT
EXIT ;EP -- exit code
+1 DO TERM^VALM0
+2 SET VALMBCK="R"
+3 DO GATHER
+4 SET VALMCNT=AMHLINE
+5 DO HDR
+6 KILL X,Y,Z,I
+7 QUIT
NOSHOW ;EP - CALLED FROM PROTOCOL
+1 DO FULL^VALM1
+2 WRITE !!,"This option is used to enter a No-Show visit for a client who failed"
+3 WRITE !,"to show for his/her group session."
+4 DO EN^VALM2(XQORNOD(0),"OS")
+5 IF '$DATA(VALMY)
WRITE !,"No records selected."
DO EXIT
QUIT
+6 SET R=$ORDER(VALMY(0))
IF 'R
KILL R,VALMY,XQORNOD
WRITE !,"No record selected."
DO EXIT
QUIT
+7 SET AMHG=0
SET AMHG=^TMP($JOB,"AMHEGR","IDX",R,R)
+8 IF '$DATA(^AMHGROUP(AMHG,0))
WRITE !,"Not a valid GROUP."
KILL AMHRDEL,R,AMHG,R1
DO PAUSE
DO EXIT
QUIT
+9 SET AMHDATE=$PIECE(^AMHGROUP(AMHG,0),U)
+10 SET AMHPTYPE=$PIECE(^AMHGROUP(AMHG,0),U,2)
+11 SET AMHVTYPE="R"
+12 SET AMHPAT=""
+13 DO GETPAT^AMHLEA
+14 IF AMHPAT=""
WRITE !!,"No patient entered"
HANG 2
DO EXIT
QUIT
+15 SET DFN=AMHPAT
+16 DO ADDNS
+17 KILL AMHPAT,DFN,AMHDATE,AMHPTYPE,AMHVTYPE
+18 DO EXIT
+19 QUIT
ADDNS ;EP
+1 DO ADDNS^AMHEGS
+2 QUIT
INTX(X) ;
+1 IF '$DATA(^AUPNPAT(X))
QUIT 0
+2 IF '$$ALLOWP^AMHUTIL(DUZ,X)
DO NALLOWP^AMHUTIL
QUIT 0
+3 NEW %,D
+4 SET %=$$DOD^AUPNPAT(X)
IF %=""
QUIT 0
+5 SET D=$SELECT($GET(AMHDATE):$PIECE(AMHDATE,"."),$GET(DA(1)):$PIECE(^AMHGROUP(DA(1),0),U,1))
+6 IF $GET(D)
IF $PIECE(D,".")>%
KILL X
QUIT 0
+7 QUIT 1
ALIVE ;EP
+1 IF '$DATA(X)
QUIT
+2 NEW %,D
+3 SET %=$$DOD^AUPNPAT(X)
IF %=""
QUIT
+4 SET D=$SELECT($GET(AMHDATE):$PIECE(AMHDATE,"."),$GET(DA(1)):$PIECE(^AMHGROUP(DA(1),0),U,1))
+5 IF $GET(D)
IF $PIECE(D,".")>%
KILL X
DO EN^DDIOL("Patient is deceased as of the visit date.")
KILL X
QUIT
+6 QUIT
PP(G) ;EP
+1 NEW X,Y
+2 SET Y=""
+3 SET X=0
FOR
SET X=$ORDER(^AMHGROUP(G,11,X))
IF X'=+X
QUIT
IF $PIECE(^AMHGROUP(G,11,X,0),U,2)="P"
SET Y=$PIECE(^AMHGROUP(G,11,X,0),U,1)
+4 QUIT Y
