AMHEGR1 ; IHS/CMI/LAB - GROUP ENTRY ;
;;4.0;IHS BEHAVIORAL HEALTH;**1,2,5**;JUN 02, 2010;Build 18
;
;
DEL ;EP - called from protocol
;add code to not allow delete unless they have the key
I '$D(^XUSEC("AMHZ DELETE RECORD",DUZ)) W !!,"You do not have the security access to delete a Group entry.",!,"Please see your supervisor or program manager.",! D PAUSE,EXIT^AMHEGR Q
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." D EXIT^AMHEGR Q
S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT^AMHEGR 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 D EXIT^AMHEGR Q
I $P(^AMHGROUP(AMHG,0),U,18),'$D(^XUSEC("AMHZ DELETE SIGNED NOTE",DUZ)) W !!,"This Group has been signed and you do not have security access to delete ",!,"a signed group. See your supervisor.",! D PAUSE,EXIT^AMHEGR Q
D FULL^VALM1
S DA=AMHG,DIC="^AMHGROUP(" D EN^DIQ
W !
S AMHDELT=2
;W !!,"Option 1 should be chosen if your intent is to just delete the group"
;W !,"definition but retain all of the individual patient encounter records"
;W !,"for this group. This option is used primarily to manage the size of"
;W !,"the group definition list view."
;W !!,"Option 2 should be chosen if your intent is to delete the group definition"
;W !,"and delete all the individual encounter records associated with this group."
;W !,"This option is used primarily when a group is entered in error."
;W !
;S DIR(0)="S^1:Delete the Group Definition Only;2:Delete Group Definition and patient encounter records",DIR("A")="Do you wish to",DIR("B")="1" KILL DA D ^DIR KILL DIR
;I $D(DIRUT) D EXIT^AMHEGR Q
;S AMHDELT=+Y
;K DIR
;I AMHDELT=1 D
;.W !!,"Removing the group definition will only remove/delete the group"
;.W !,"definition from the list. It will not remove/delete the individual"
;.W !,"patient encounter records associated with the group."
;.W !
;.S DIR("A")="Are you sure you want to delete the group definition only"
I AMHDELT=2,$P(^AMHGROUP(AMHG,0),U,18),'$D(^XUSEC("AMHZ DELETE SIGNED NOTE",DUZ)) D D PAUSE,EXIT^AMHEGR Q
.W !,"The SOAP/Progress notes associated with this group have been signed."
.W !,"You cannot delete both the group definition and the visits."
I AMHDELT=2 D
.W !,"This option will remove/delete both the group definition and the "
.W !,"associated patient encounter records."
.W !!,"Are you sure you want to remove/delete both the group defintion and all "
.S DIR("A")="associated individual patient records"
S DIR(0)="Y",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D EXIT^AMHEGR Q
I 'Y D EXIT^AMHEGR Q
I AMHDELT=1 S DA=AMHG,DIK="^AMHGROUP(" D ^DIK K DIK D EXIT^AMHEGR Q
I AMHDELT=2 D S DA=AMHG,DIK="^AMHGROUP(" D ^DIK K DIK
.S AMHX=0 F S AMHX=$O(^AMHGROUP(AMHG,61,AMHX)) Q:AMHX'=+AMHX D
..S AMHR=$P($G(^AMHGROUP(AMHG,61,AMHX,0)),U)
..S AMHGRPDE=1 D DELR K AMHGRPDE
D EXIT^AMHEGR
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
DELR ;EP
I '$D(^XUSEC("AMHZ DELETE SIGNED NOTE",DUZ)),$P($G(^AMHREC(AMHR,11)),U,12)]"" D Q
.W !!,$$VAL^XBDIQ1(9002011,AMHR,.01),?20,$$VAL^XBDIQ1(9002011,AMHR,.08)
.W !!,"The progress note associated with this visit has been signed. You cannot delete this visit.",!,"Please see your supervisor or program manager.",!
I $$IINTAKE^AMHLEDEL(AMHR) W !!,"This visit has an Initial Intake with Updates, it can not be deleted",!,"until the update documents have been deleted." D PAUSE Q
S AMHVDLT=$P(^AMHREC(AMHR,0),U,16),AMHACTN=4
S AMHRDEL=AMHR
D EN^XBNEW("DEL^AMHLEE","AMHR;AMHVDLT;AMHACTN;AMHGRPDE")
Q
SOAP ;EP - put in standard soap
S (X,C)=0 F S X=$O(^AMHGROUP(AMHNG,31,X)) Q:X'=+X S C=C+1,^AMHREC(AMHR,31,C,0)=^AMHGROUP(AMHNG,31,X,0)
S ^AMHREC(AMHR,31,0)="^^"_C_"^"_C_"^"_DT_"^^"
D ^XBFMK
S DIE="^AMHREC(",DA=AMHR,DR=3101 D ^DIE
S AMHOKAY=0 D RECCHECK^AMHLE2 I AMHOKAY W !,"Incomplete record!! Deleting record!!" D DELR Q
;update 61 multiple
D ^XBFMK
S X=AMHR
S DA(1)=AMHNG,DIC="^AMHGROUP("_AMHNG_",61,",DIC(0)="AELQ",DIC("P")=$P(^DD(9002011.67,6101,0),U,2)
K DD,DO D FILE^DICN
I Y=-1 W !!,"adding record to group failed."
;call pcc link
;S AMHIAIG=1 D PCCLINK^AMHLE2
;K AMHIAIG
D EXIT^AMHEGR
Q
PRTEF ;EP
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." D EXIT^AMHEGR Q
S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT^AMHEGR Q
S AMHNG=0 S AMHNG=^TMP($J,"AMHEGR","IDX",R,R)
I '$D(^AMHGROUP(AMHNG,0)) W !,"Not a valid GROUP." K R,AMHNG,R1 D PAUSE,EXIT^AMHEGR Q
D FULL^VALM1
I '$O(^AMHGROUP(AMHNG,61,0)) W !!,"There were no visits created for this group." D PAUSE,EXIT^AMHEGR Q
W !!,"Forms will be generated for the following patient visits:"
S AMHY=0 F S AMHY=$O(^AMHGROUP(AMHNG,61,AMHY)) Q:'AMHY S AMHR=$P(^AMHGROUP(AMHNG,61,AMHY,0),U) I $D(^AMHREC(AMHR,0)) D
.W !?2,$$VAL^XBDIQ1(9002011,AMHR,.08),?34,$$VAL^XBDIQ1(9002011,AMHR,.01)
.S AMHLEGP("RECS ADDED",AMHY)=AMHR
K AMHEFT,AMHEFTH
W !! S DIR(0)="S^F:Full Encounter Form;S:Suppressed Encounter Form;B:Both a Suppressed & Full;T:2 copies of the Suppressed;E:2 copies of the Full"
S DIR("B")=$S($P(^AMHSITE(DUZ(2),0),U,23)]"":$P(^AMHSITE(DUZ(2),0),U,23),1:"B") K DA D ^DIR K DIR
Q:$D(DIRUT)
S (AMHEFT,AMHEFTH)=Y
S AMHGRPN=$P(^AMHGROUP(AMHNG,0),U,3)
S XBRP="PRINT^AMHLEGPP",XBRC="COMP^AMHLEGPP",XBRX="XIT^AMHLEGPP",XBNS="AMH"
D ^XBDBQUE
D EXIT^AMHEGR
Q
DISP ;EP - called from protocol
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." D EXIT^AMHEGR Q
S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT^AMHEGR 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^AMHEGR Q
D FULL^VALM1
D DIQ^XBLM(9002011.67,AMHG)
D EXIT^AMHEGR
Q
ESIGGRP ;
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No Group selected." D EXIT^AMHEGR Q
S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No Group selected." D EXIT^AMHEGR Q
S AMHNG=0 S AMHNG=^TMP($J,"AMHEGR","IDX",R,R)
I '$D(^AMHGROUP(AMHNG,0)) W !,"Not a valid GROUP." K R,AMHNG,R1 D PAUSE,EXIT^AMHEGR Q
D FULL^VALM1
I '$O(^AMHGROUP(AMHNG,61,0)) W !!,"There were no visits created for this group." D PAUSE,EXIT^AMHEGR Q
I $P(^AMHGROUP(AMHNG,0),U,18) W !!,"The notes for this group have already been signed.",!! D PAUSE,EXIT^AMHEGR Q
S P=$$PP^AMHEGR(AMHNG)
I $D(^AMHSITE(DUZ(2),19,"B",P)) W !!,"No E-Sig Required. Provider opted out of E-Sig." D PAUSE,EXIT^AMHEGR Q
D SIGN^AMHEGR
Q
GATHER ;EP
K ^TMP($J,"AMHEGR")
S AMHLINE=0,AMHD=$$FMADD^XLFDT(AMHRED,1)
F S AMHD=$O(^AMHGROUP("B",AMHD),-1) Q:AMHD'=+AMHD!($P(AMHD,".")<AMHRBD) D
.S AMHX=0 F S AMHX=$O(^AMHGROUP("B",AMHD,AMHX)) Q:AMHX'=+AMHX D
..S AMHN=$G(^AMHGROUP(AMHX,0))
..Q:'$$ALLOWV^AMHUTIL(DUZ,$P(AMHN,U,5))
..S AMHPRVM=""
..I $O(^AMHSITE(DUZ(2),16,"B",DUZ,0)) S AMHPRVM=1
..I '$O(^AMHSITE(DUZ(2),16,"B",DUZ,0)) D
...I $$PRVG^AMHGU(AMHX,DUZ) S AMHPRVM=1 Q ;quit if not provider who entered
...I $$GET1^DIQ(9002011.67,AMHX,.12,"I")=DUZ S AMHPRVM=1 Q
.. Q:'$G(AMHPRVM)
..S AMHLINE=AMHLINE+1,X=AMHLINE_")",$E(X,5)=$S('$P(^AMHGROUP(AMHX,0),U,18):"*",1:""),$E(X,7)=$E(AMHD,4,5)_"/"_$E(AMHD,6,7)_"/"_$E(AMHD,2,3),$E(X,16)=$E($P(AMHN,U,3),1,20)
..S A=$P(AMHN,U,7) I A S A=$P(^AMHTACT(A,0),U,2),A=$E(A,1,9),$E(X,37)=A
..S $E(X,48)=$E($P(AMHN,U,2),1)
..S $E(X,52)=$E($$VAL^XBDIQ1(9002011.67,AMHX,.14),1,5)
..S $E(X,59)=$E($$PPINI(AMHX),1,8)
..S $E(X,69)=$E($$VAL^XBDIQ1(9002011.67,AMHX,.08),1,3)
..S $E(X,73)=$$POV(AMHX)
..S ^TMP($J,"AMHEGR",AMHLINE,0)=X,^TMP($J,"AMHEGR","IDX",AMHLINE,AMHLINE)=AMHX
Q
PPINI(R) ;
I 'R Q ""
NEW Y,X
S X=0,Y="" F S X=$O(^AMHGROUP(R,11,X)) Q:X'=+X!(Y]"") I $P($G(^AMHGROUP(R,11,X,0)),U,2)="P" S Y=$P(^AMHGROUP(R,11,X,0),U),Y=$P(^VA(200,Y,0),U,1)
Q Y
POV(R) ;
I 'R Q ""
NEW Y,X,P
S X=0,Y="" F S X=$O(^AMHGROUP(R,21,X)) Q:X'=+X!(Y]"") S P=$P(^AMHGROUP(R,21,X,0),U),Y=$P(^AMHPROB(P,0),U,1)_" - "_$P(^AMHPROB(P,0),U,2)
Q Y
DUP ;EP
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." D EXIT^AMHEGR Q
S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT^AMHEGR 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 D EXIT^AMHEGR Q
D FULL^VALM1
W !
K DIR S DIR(0)="D^:DT:EP",DIR("A")="Enter Date for the new group entry" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D EXIT^AMHEGR Q
S AMHD=Y,AMHDATE=Y
S X=AMHD,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^AMHEGR Q
S AMHNG=+Y
K DIADD,DLAYGO D ^XBFMK
K ^AMHGROUP("B",AMHD,AMHNG)
M ^AMHGROUP(AMHNG)=^AMHGROUP(AMHG)
K ^AMHGROUP(AMHNG,61) ;get rid of records
K ^AMHGROUP(AMHNG,71) ;get rid of patient ed topics per BJ 5.13.09
;per BJ 5/13/09 - get rid of deceased patients
NEW AMHX,P
S AMHX=0 F S AMHX=$O(^AMHGROUP(AMHNG,51,AMHX)) Q:AMHX'=+AMHX D
.S P=$P($G(^AMHGROUP(AMHNG,51,AMHX,0)),U)
.Q:P=""
.I $$DOD^AUPNPAT(P)]"" D
..S DA(1)=AMHNG,DA=AMHX,DIK="^AMHGROUP("_DA(1)_",51," D ^DIK K DA,DIK
;GET RID OF INACTIVE POVS
S AMHX=0 F S AMHX=$O(^AMHGROUP(AMHNG,21,AMHX)) Q:AMHX'=+AMHX D
.S P=$P($G(^AMHGROUP(AMHNG,21,AMHX,0)),U,1)
.I '$$CHKD^AMHUTIL1(P,AMHDATE) D
..S DA(1)=AMHNG,DA=AMHX,DIK="^AMHGROUP("_DA(1)_",21," D ^DIK K DA,DIK
;GET RID OF INACTIVECPTS
S AMHX=0 F S AMHX=$O(^AMHGROUP(AMHNG,41,AMHX)) Q:AMHX'=+AMHX D
.S P=$P($G(^AMHGROUP(AMHNG,41,AMHX,0)),U,1)
.D CPT^AMHUTIL1(P,AMHDATE) I '$T D Q
..S DA(1)=AMHNG,DA=AMHX,DIK="^AMHGROUP("_DA(1)_",41," D ^DIK K DA,DIK
.I '$P(^AMHGROUP(AMHNG,41,AMHX,0),U,2) S $P(^AMHGROUP(AMHNG,41,AMHX,0),U,2)=1
S DA=AMHNG,DIE="^AMHGROUP(",DR=".01///"_AMHD_";.04////"_DT_";.12////"_DUZ_";.13////"_DT_";.15////"_DUZ_";.16///@;.18///@;.19///@;.21///@" D ^DIE
S DA=AMHNG,DIK="^AMHGROUP(" D IX1^DIK
D EDITGRP^AMHEGR
Q
PCCLINK ;EP
W !!,"Processing PCC Link for all visits..."
NEW AMHGX
S AMHACTN=1
S AMHGX=0 F S AMHGX=$O(^AMHGROUP(AMHNG,61,AMHGX)) Q:AMHGX'=+AMHGX D
.S AMHR=$P(^AMHGROUP(AMHNG,61,AMHGX,0),U)
.I '$D(^AMHREC(AMHR,0)) W !!,"a previously entered visit has been deleted, skipping signature for that visit" Q
.I $P($$ESIG^AMHESIG(AMHR,1),U,1) W !,"Signing note for ",$$VAL^XBDIQ1(9002011,AMHR,.08) D
..S DIE="^AMHREC(",DA=AMHR,DR="1112///NOW;1113///"_$P($G(^VA(200,DUZ,20)),U,2)_";1116///"_$P(^VA(200,DUZ,20),U,3) D ^DIE K DA,DIE,DR
..I $D(Y) W !!,"Error updating electronic signature...see your supervisor for programmer help."
.S AMHACTN=1
.W !,"Processing PCC Link for ",$$VAL^XBDIQ1(9002011,AMHR,.08)
.S AMHDATE=$P($P(^AMHGROUP(AMHNG,0),U),".")
.S AMHPTYPE=$P(^AMHGROUP(AMHNG,0),U,2)
.S AMHLOC=$P(^AMHGROUP(AMHNG,0),U,5)
.D PCCLINK^AMHLE2
I AMHSIGN K DIE,DA,DR,Y,DIU,DIV S DIE="^AMHGROUP(",DA=AMHNG,DR=".21///NOW;.19///"_$P($G(^VA(200,DUZ,20)),U,2)_";.18///1" D ^DIE K DA,DIE,DR
Q
AMHEGR1 ; IHS/CMI/LAB - GROUP ENTRY ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1,2,5**;JUN 02, 2010;Build 18
+2 ;
+3 ;
DEL ;EP - called from protocol
+1 ;add code to not allow delete unless they have the key
+2 IF '$DATA(^XUSEC("AMHZ DELETE RECORD",DUZ))
WRITE !!,"You do not have the security access to delete a Group entry.",!,"Please see your supervisor or program manager.",!
DO PAUSE
DO EXIT^AMHEGR
QUIT
+3 DO EN^VALM2(XQORNOD(0),"OS")
+4 IF '$DATA(VALMY)
WRITE !,"No records selected."
DO EXIT^AMHEGR
QUIT
+5 SET R=$ORDER(VALMY(0))
IF 'R
KILL R,VALMY,XQORNOD
WRITE !,"No record selected."
DO EXIT^AMHEGR
QUIT
+6 SET AMHG=0
SET AMHG=^TMP($JOB,"AMHEGR","IDX",R,R)
+7 IF '$DATA(^AMHGROUP(AMHG,0))
WRITE !,"Not a valid GROUP."
KILL AMHRDEL,R,AMHG,R1
DO PAUSE
DO EXIT^AMHEGR
QUIT
+8 IF $PIECE(^AMHGROUP(AMHG,0),U,18)
IF '$DATA(^XUSEC("AMHZ DELETE SIGNED NOTE",DUZ))
WRITE !!,"This Group has been signed and you do not have security access to delete ",!,"a signed group. See your supervisor.",!
DO PAUSE
DO EXIT^AMHEGR
QUIT
+9 DO FULL^VALM1
+10 SET DA=AMHG
SET DIC="^AMHGROUP("
DO EN^DIQ
+11 WRITE !
+12 SET AMHDELT=2
+13 ;W !!,"Option 1 should be chosen if your intent is to just delete the group"
+14 ;W !,"definition but retain all of the individual patient encounter records"
+15 ;W !,"for this group. This option is used primarily to manage the size of"
+16 ;W !,"the group definition list view."
+17 ;W !!,"Option 2 should be chosen if your intent is to delete the group definition"
+18 ;W !,"and delete all the individual encounter records associated with this group."
+19 ;W !,"This option is used primarily when a group is entered in error."
+20 ;W !
+21 ;S DIR(0)="S^1:Delete the Group Definition Only;2:Delete Group Definition and patient encounter records",DIR("A")="Do you wish to",DIR("B")="1" KILL DA D ^DIR KILL DIR
+22 ;I $D(DIRUT) D EXIT^AMHEGR Q
+23 ;S AMHDELT=+Y
+24 ;K DIR
+25 ;I AMHDELT=1 D
+26 ;.W !!,"Removing the group definition will only remove/delete the group"
+27 ;.W !,"definition from the list. It will not remove/delete the individual"
+28 ;.W !,"patient encounter records associated with the group."
+29 ;.W !
+30 ;.S DIR("A")="Are you sure you want to delete the group definition only"
+31 IF AMHDELT=2
IF $PIECE(^AMHGROUP(AMHG,0),U,18)
IF '$DATA(^XUSEC("AMHZ DELETE SIGNED NOTE",DUZ))
Begin DoDot:1
+32 WRITE !,"The SOAP/Progress notes associated with this group have been signed."
+33 WRITE !,"You cannot delete both the group definition and the visits."
End DoDot:1
DO PAUSE
DO EXIT^AMHEGR
QUIT
+34 IF AMHDELT=2
Begin DoDot:1
+35 WRITE !,"This option will remove/delete both the group definition and the "
+36 WRITE !,"associated patient encounter records."
+37 WRITE !!,"Are you sure you want to remove/delete both the group defintion and all "
+38 SET DIR("A")="associated individual patient records"
End DoDot:1
+39 SET DIR(0)="Y"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+40 IF $DATA(DIRUT)
DO EXIT^AMHEGR
QUIT
+41 IF 'Y
DO EXIT^AMHEGR
QUIT
+42 IF AMHDELT=1
SET DA=AMHG
SET DIK="^AMHGROUP("
DO ^DIK
KILL DIK
DO EXIT^AMHEGR
QUIT
+43 IF AMHDELT=2
Begin DoDot:1
+44 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHGROUP(AMHG,61,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:2
+45 SET AMHR=$PIECE($GET(^AMHGROUP(AMHG,61,AMHX,0)),U)
+46 SET AMHGRPDE=1
DO DELR
KILL AMHGRPDE
End DoDot:2
End DoDot:1
SET DA=AMHG
SET DIK="^AMHGROUP("
DO ^DIK
KILL DIK
+47 DO EXIT^AMHEGR
+48 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
DELR ;EP
+1 IF '$DATA(^XUSEC("AMHZ DELETE SIGNED NOTE",DUZ))
IF $PIECE($GET(^AMHREC(AMHR,11)),U,12)]""
Begin DoDot:1
+2 WRITE !!,$$VAL^XBDIQ1(9002011,AMHR,.01),?20,$$VAL^XBDIQ1(9002011,AMHR,.08)
+3 WRITE !!,"The progress note associated with this visit has been signed. You cannot delete this visit.",!,"Please see your supervisor or program manager.",!
End DoDot:1
QUIT
+4 IF $$IINTAKE^AMHLEDEL(AMHR)
WRITE !!,"This visit has an Initial Intake with Updates, it can not be deleted",!,"until the update documents have been deleted."
DO PAUSE
QUIT
+5 SET AMHVDLT=$PIECE(^AMHREC(AMHR,0),U,16)
SET AMHACTN=4
+6 SET AMHRDEL=AMHR
+7 DO EN^XBNEW("DEL^AMHLEE","AMHR;AMHVDLT;AMHACTN;AMHGRPDE")
+8 QUIT
SOAP ;EP - put in standard soap
+1 SET (X,C)=0
FOR
SET X=$ORDER(^AMHGROUP(AMHNG,31,X))
IF X'=+X
QUIT
SET C=C+1
SET ^AMHREC(AMHR,31,C,0)=^AMHGROUP(AMHNG,31,X,0)
+2 SET ^AMHREC(AMHR,31,0)="^^"_C_"^"_C_"^"_DT_"^^"
+3 DO ^XBFMK
+4 SET DIE="^AMHREC("
SET DA=AMHR
SET DR=3101
DO ^DIE
+5 SET AMHOKAY=0
DO RECCHECK^AMHLE2
IF AMHOKAY
WRITE !,"Incomplete record!! Deleting record!!"
DO DELR
QUIT
+6 ;update 61 multiple
+7 DO ^XBFMK
+8 SET X=AMHR
+9 SET DA(1)=AMHNG
SET DIC="^AMHGROUP("_AMHNG_",61,"
SET DIC(0)="AELQ"
SET DIC("P")=$PIECE(^DD(9002011.67,6101,0),U,2)
+10 KILL DD,DO
DO FILE^DICN
+11 IF Y=-1
WRITE !!,"adding record to group failed."
+12 ;call pcc link
+13 ;S AMHIAIG=1 D PCCLINK^AMHLE2
+14 ;K AMHIAIG
+15 DO EXIT^AMHEGR
+16 QUIT
PRTEF ;EP
+1 DO EN^VALM2(XQORNOD(0),"OS")
+2 IF '$DATA(VALMY)
WRITE !,"No records selected."
DO EXIT^AMHEGR
QUIT
+3 SET R=$ORDER(VALMY(0))
IF 'R
KILL R,VALMY,XQORNOD
WRITE !,"No record selected."
DO EXIT^AMHEGR
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 R,AMHNG,R1
DO PAUSE
DO EXIT^AMHEGR
QUIT
+6 DO FULL^VALM1
+7 IF '$ORDER(^AMHGROUP(AMHNG,61,0))
WRITE !!,"There were no visits created for this group."
DO PAUSE
DO EXIT^AMHEGR
QUIT
+8 WRITE !!,"Forms will be generated for the following patient visits:"
+9 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHGROUP(AMHNG,61,AMHY))
IF 'AMHY
QUIT
SET AMHR=$PIECE(^AMHGROUP(AMHNG,61,AMHY,0),U)
IF $DATA(^AMHREC(AMHR,0))
Begin DoDot:1
+10 WRITE !?2,$$VAL^XBDIQ1(9002011,AMHR,.08),?34,$$VAL^XBDIQ1(9002011,AMHR,.01)
+11 SET AMHLEGP("RECS ADDED",AMHY)=AMHR
End DoDot:1
+12 KILL AMHEFT,AMHEFTH
+13 WRITE !!
SET DIR(0)="S^F:Full Encounter Form;S:Suppressed Encounter Form;B:Both a Suppressed & Full;T:2 copies of the Suppressed;E:2 copies of the Full"
+14 SET DIR("B")=$SELECT($PIECE(^AMHSITE(DUZ(2),0),U,23)]"":$PIECE(^AMHSITE(DUZ(2),0),U,23),1:"B")
KILL DA
DO ^DIR
KILL DIR
+15 IF $DATA(DIRUT)
QUIT
+16 SET (AMHEFT,AMHEFTH)=Y
+17 SET AMHGRPN=$PIECE(^AMHGROUP(AMHNG,0),U,3)
+18 SET XBRP="PRINT^AMHLEGPP"
SET XBRC="COMP^AMHLEGPP"
SET XBRX="XIT^AMHLEGPP"
SET XBNS="AMH"
+19 DO ^XBDBQUE
+20 DO EXIT^AMHEGR
+21 QUIT
DISP ;EP - called from protocol
+1 DO EN^VALM2(XQORNOD(0),"OS")
+2 IF '$DATA(VALMY)
WRITE !,"No records selected."
DO EXIT^AMHEGR
QUIT
+3 SET R=$ORDER(VALMY(0))
IF 'R
KILL R,VALMY,XQORNOD
WRITE !,"No record selected."
DO EXIT^AMHEGR
QUIT
+4 SET AMHG=0
SET AMHG=^TMP($JOB,"AMHEGR","IDX",R,R)
+5 IF '$DATA(^AMHGROUP(AMHG,0))
WRITE !,"Not a valid GROUP."
KILL AMHRDEL,R,AMHG,R1
DO PAUSE
DO EXIT^AMHEGR
QUIT
+6 DO FULL^VALM1
+7 DO DIQ^XBLM(9002011.67,AMHG)
+8 DO EXIT^AMHEGR
+9 QUIT
ESIGGRP ;
+1 DO EN^VALM2(XQORNOD(0),"OS")
+2 IF '$DATA(VALMY)
WRITE !,"No Group selected."
DO EXIT^AMHEGR
QUIT
+3 SET R=$ORDER(VALMY(0))
IF 'R
KILL R,VALMY,XQORNOD
WRITE !,"No Group selected."
DO EXIT^AMHEGR
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 R,AMHNG,R1
DO PAUSE
DO EXIT^AMHEGR
QUIT
+6 DO FULL^VALM1
+7 IF '$ORDER(^AMHGROUP(AMHNG,61,0))
WRITE !!,"There were no visits created for this group."
DO PAUSE
DO EXIT^AMHEGR
QUIT
+8 IF $PIECE(^AMHGROUP(AMHNG,0),U,18)
WRITE !!,"The notes for this group have already been signed.",!!
DO PAUSE
DO EXIT^AMHEGR
QUIT
+9 SET P=$$PP^AMHEGR(AMHNG)
+10 IF $DATA(^AMHSITE(DUZ(2),19,"B",P))
WRITE !!,"No E-Sig Required. Provider opted out of E-Sig."
DO PAUSE
DO EXIT^AMHEGR
QUIT
+11 DO SIGN^AMHEGR
+12 QUIT
GATHER ;EP
+1 KILL ^TMP($JOB,"AMHEGR")
+2 SET AMHLINE=0
SET AMHD=$$FMADD^XLFDT(AMHRED,1)
+3 FOR
SET AMHD=$ORDER(^AMHGROUP("B",AMHD),-1)
IF AMHD'=+AMHD!($PIECE(AMHD,".")<AMHRBD)
QUIT
Begin DoDot:1
+4 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHGROUP("B",AMHD,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:2
+5 SET AMHN=$GET(^AMHGROUP(AMHX,0))
+6 IF '$$ALLOWV^AMHUTIL(DUZ,$PIECE(AMHN,U,5))
QUIT
+7 SET AMHPRVM=""
+8 IF $ORDER(^AMHSITE(DUZ(2),16,"B",DUZ,0))
SET AMHPRVM=1
+9 IF '$ORDER(^AMHSITE(DUZ(2),16,"B",DUZ,0))
Begin DoDot:3
+10 ;quit if not provider who entered
IF $$PRVG^AMHGU(AMHX,DUZ)
SET AMHPRVM=1
QUIT
+11 IF $$GET1^DIQ(9002011.67,AMHX,.12,"I")=DUZ
SET AMHPRVM=1
QUIT
End DoDot:3
+12 IF '$GET(AMHPRVM)
QUIT
+13 SET AMHLINE=AMHLINE+1
SET X=AMHLINE_")"
SET $EXTRACT(X,5)=$SELECT('$PIECE(^AMHGROUP(AMHX,0),U,18):"*",1:"")
SET $EXTRACT(X,7)=$EXTRACT(AMHD,4,5)_"/"_$EXTRACT(AMHD,6,7)_"/"_$EXTRACT(AMHD,2,3)
SET $EXTRACT(X,16)=$EXTRACT($PIECE(AMHN,U,3),1,20)
+14 SET A=$PIECE(AMHN,U,7)
IF A
SET A=$PIECE(^AMHTACT(A,0),U,2)
SET A=$EXTRACT(A,1,9)
SET $EXTRACT(X,37)=A
+15 SET $EXTRACT(X,48)=$EXTRACT($PIECE(AMHN,U,2),1)
+16 SET $EXTRACT(X,52)=$EXTRACT($$VAL^XBDIQ1(9002011.67,AMHX,.14),1,5)
+17 SET $EXTRACT(X,59)=$EXTRACT($$PPINI(AMHX),1,8)
+18 SET $EXTRACT(X,69)=$EXTRACT($$VAL^XBDIQ1(9002011.67,AMHX,.08),1,3)
+19 SET $EXTRACT(X,73)=$$POV(AMHX)
+20 SET ^TMP($JOB,"AMHEGR",AMHLINE,0)=X
SET ^TMP($JOB,"AMHEGR","IDX",AMHLINE,AMHLINE)=AMHX
End DoDot:2
End DoDot:1
+21 QUIT
PPINI(R) ;
+1 IF 'R
QUIT ""
+2 NEW Y,X
+3 SET X=0
SET Y=""
FOR
SET X=$ORDER(^AMHGROUP(R,11,X))
IF X'=+X!(Y]"")
QUIT
IF $PIECE($GET(^AMHGROUP(R,11,X,0)),U,2)="P"
SET Y=$PIECE(^AMHGROUP(R,11,X,0),U)
SET Y=$PIECE(^VA(200,Y,0),U,1)
+4 QUIT Y
POV(R) ;
+1 IF 'R
QUIT ""
+2 NEW Y,X,P
+3 SET X=0
SET Y=""
FOR
SET X=$ORDER(^AMHGROUP(R,21,X))
IF X'=+X!(Y]"")
QUIT
SET P=$PIECE(^AMHGROUP(R,21,X,0),U)
SET Y=$PIECE(^AMHPROB(P,0),U,1)_" - "_$PIECE(^AMHPROB(P,0),U,2)
+4 QUIT Y
DUP ;EP
+1 DO EN^VALM2(XQORNOD(0),"OS")
+2 IF '$DATA(VALMY)
WRITE !,"No records selected."
DO EXIT^AMHEGR
QUIT
+3 SET R=$ORDER(VALMY(0))
IF 'R
KILL R,VALMY,XQORNOD
WRITE !,"No record selected."
DO EXIT^AMHEGR
QUIT
+4 SET AMHG=0
SET AMHG=^TMP($JOB,"AMHEGR","IDX",R,R)
+5 IF '$DATA(^AMHGROUP(AMHG,0))
WRITE !,"Not a valid GROUP."
KILL AMHRDEL,R,AMHG,R1
DO PAUSE
DO EXIT^AMHEGR
QUIT
+6 DO FULL^VALM1
+7 WRITE !
+8 KILL DIR
SET DIR(0)="D^:DT:EP"
SET DIR("A")="Enter Date for the new group entry"
KILL DA
DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)
DO EXIT^AMHEGR
QUIT
+10 SET AMHD=Y
SET AMHDATE=Y
+11 SET X=AMHD
SET DIC="^AMHGROUP("
SET DLAYGO=9002011.67
SET DIADD=1
SET DIC(0)="L"
KILL DD,DO
DO FILE^DICN
+12 IF Y=-1
WRITE !!,"entry of new group failed."
KILL DIADD,DLAYGO
DO ^XBFMK
DO EXIT^AMHEGR
QUIT
+13 SET AMHNG=+Y
+14 KILL DIADD,DLAYGO
DO ^XBFMK
+15 KILL ^AMHGROUP("B",AMHD,AMHNG)
+16 MERGE ^AMHGROUP(AMHNG)=^AMHGROUP(AMHG)
+17 ;get rid of records
KILL ^AMHGROUP(AMHNG,61)
+18 ;get rid of patient ed topics per BJ 5.13.09
KILL ^AMHGROUP(AMHNG,71)
+19 ;per BJ 5/13/09 - get rid of deceased patients
+20 NEW AMHX,P
+21 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHGROUP(AMHNG,51,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+22 SET P=$PIECE($GET(^AMHGROUP(AMHNG,51,AMHX,0)),U)
+23 IF P=""
QUIT
+24 IF $$DOD^AUPNPAT(P)]""
Begin DoDot:2
+25 SET DA(1)=AMHNG
SET DA=AMHX
SET DIK="^AMHGROUP("_DA(1)_",51,"
DO ^DIK
KILL DA,DIK
End DoDot:2
End DoDot:1
+26 ;GET RID OF INACTIVE POVS
+27 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHGROUP(AMHNG,21,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+28 SET P=$PIECE($GET(^AMHGROUP(AMHNG,21,AMHX,0)),U,1)
+29 IF '$$CHKD^AMHUTIL1(P,AMHDATE)
Begin DoDot:2
+30 SET DA(1)=AMHNG
SET DA=AMHX
SET DIK="^AMHGROUP("_DA(1)_",21,"
DO ^DIK
KILL DA,DIK
End DoDot:2
End DoDot:1
+31 ;GET RID OF INACTIVECPTS
+32 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHGROUP(AMHNG,41,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+33 SET P=$PIECE($GET(^AMHGROUP(AMHNG,41,AMHX,0)),U,1)
+34 DO CPT^AMHUTIL1(P,AMHDATE)
IF '$TEST
Begin DoDot:2
+35 SET DA(1)=AMHNG
SET DA=AMHX
SET DIK="^AMHGROUP("_DA(1)_",41,"
DO ^DIK
KILL DA,DIK
End DoDot:2
QUIT
+36 IF '$PIECE(^AMHGROUP(AMHNG,41,AMHX,0),U,2)
SET $PIECE(^AMHGROUP(AMHNG,41,AMHX,0),U,2)=1
End DoDot:1
+37 SET DA=AMHNG
SET DIE="^AMHGROUP("
SET DR=".01///"_AMHD_";.04////"_DT_";.12////"_DUZ_";.13////"_DT_";.15////"_DUZ_";.16///@;.18///@;.19///@;.21///@"
DO ^DIE
+38 SET DA=AMHNG
SET DIK="^AMHGROUP("
DO IX1^DIK
+39 DO EDITGRP^AMHEGR
+40 QUIT
PCCLINK ;EP
+1 WRITE !!,"Processing PCC Link for all visits..."
+2 NEW AMHGX
+3 SET AMHACTN=1
+4 SET AMHGX=0
FOR
SET AMHGX=$ORDER(^AMHGROUP(AMHNG,61,AMHGX))
IF AMHGX'=+AMHGX
QUIT
Begin DoDot:1
+5 SET AMHR=$PIECE(^AMHGROUP(AMHNG,61,AMHGX,0),U)
+6 IF '$DATA(^AMHREC(AMHR,0))
WRITE !!,"a previously entered visit has been deleted, skipping signature for that visit"
QUIT
+7 IF $PIECE($$ESIG^AMHESIG(AMHR,1),U,1)
WRITE !,"Signing note for ",$$VAL^XBDIQ1(9002011,AMHR,.08)
Begin DoDot:2
+8 SET DIE="^AMHREC("
SET DA=AMHR
SET DR="1112///NOW;1113///"_$PIECE($GET(^VA(200,DUZ,20)),U,2)_";1116///"_$PIECE(^VA(200,DUZ,20),U,3)
DO ^DIE
KILL DA,DIE,DR
+9 IF $DATA(Y)
WRITE !!,"Error updating electronic signature...see your supervisor for programmer help."
End DoDot:2
+10 SET AMHACTN=1
+11 WRITE !,"Processing PCC Link for ",$$VAL^XBDIQ1(9002011,AMHR,.08)
+12 SET AMHDATE=$PIECE($PIECE(^AMHGROUP(AMHNG,0),U),".")
+13 SET AMHPTYPE=$PIECE(^AMHGROUP(AMHNG,0),U,2)
+14 SET AMHLOC=$PIECE(^AMHGROUP(AMHNG,0),U,5)
+15 DO PCCLINK^AMHLE2
End DoDot:1
+16 IF AMHSIGN
KILL DIE,DA,DR,Y,DIU,DIV
SET DIE="^AMHGROUP("
SET DA=AMHNG
SET DR=".21///NOW;.19///"_$PIECE($GET(^VA(200,DUZ,20)),U,2)_";.18///1"
DO ^DIE
KILL DA,DIE,DR
+17 QUIT
