AMHGSGP ; 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("GP^AMHGSGP(.RETVAL,.AMHSTR)")
Q
;
GP(RETVAL,AMHSTR) ;-- save group data
S X="MERR^AMHGU",@^%ZOSF("TRAP") ; m error trap
N AMHI,P,R,AMHDM,AMHREC,AMHPP,AMHPRG,AMHGN,AMHCL,AMNNS,AMHTOC,AMHEL,AMHED,AMHCS,AMHACT,AMHAT,AMHSP,AMHPV,AMHPRGN,AMHCPT,AMHEDU,AMHPATS,AMHER,AMHCC
N PV,CPT,EDU,PATS
S P="|",R="~"
S RETVAL="^AMHTMP("_$J_")"
S AMHI=0
K ^AMHTMP($J)
I $G(AMHSTR)="" D CATSTR^AMHGU(.AMHSTR,.AMHSTR)
S AMHDM=$P(AMHSTR,P)
S AMHREC=$P(AMHSTR,P,2)
S AMHPP=$P(AMHSTR,P,3)
S AMHPRG=$$SCI^AMHGT(9002011.67,.02,$P(AMHSTR,P,4))
S AMHGN=$P(AMHSTR,P,5)
S AMHCL=$P(AMHSTR,P,6)
S AMHNS=$P(AMHSTR,P,7)
S AMHTOC=$P(AMHSTR,P,8)
S AMHEL=$P(AMHSTR,P,9)
S AMHED=+$P(AMHSTR,P,10)
S AMHCS=$P(AMHSTR,P,11)
S AMHACT=$P(AMHSTR,P,12)
S AMHAT=$P(AMHSTR,P,13)
S AMHSP=$P(AMHSTR,P,14)
S AMHPV=$P(AMHSTR,P,15)
S AMHPRGN=$P(AMHSTR,P,16)
S AMHCPT=$P(AMHSTR,P,17)
S AMHEDU=$P(AMHSTR,P,18)
S AMHPATS=$P(AMHSTR,P,19)
S AMHCC=$P(AMHSTR,P,20)
D ARRAY^AMHGU(.PV,AMHPV)
D ARRAY^AMHGU(.CPT,AMHCPT)
D ARRAY^AMHGU(.EDU,AMHEDU)
D ARRAY^AMHGU(.PATS,AMHPATS)
D GP^AMHGEGP(.AMHREC,AMHDM,AMHREC,AMHPRG,AMHGN,AMHCL,AMHNS,AMHTOC,AMHEL,AMHED,AMHCS,AMHACT,AMHAT,AMHCC)
I $G(AMHER)="" D CLNPRV^AMHGEGP(AMHREC)
I $G(AMHER)="" D MODPRV^AMHGEGP(AMHPP,AMHDM,AMHREC,"","P")
;v4.0p2 ihs/cmi/maw modified all below to not file if in edit mode
I $G(AMHER)="",AMHDM="A" D SP^AMHGEGP(AMHDM,AMHREC,"",AMHSP)
I $G(AMHER)="",AMHDM="A" D GPOV^AMHGEGP(AMHDM,AMHREC,.PV)
I $G(AMHER)="",AMHDM="A" D PN^AMHGEGP(AMHDM,AMHREC,AMHPRGN,"")
I $G(AMHER)="",AMHDM="A" D CPT^AMHGEGP(AMHREC,.CPT)
I $G(AMHER)="",AMHDM="A" D EDU^AMHGEGP(AMHREC,.EDU)
I $G(AMHER)="",AMHDM="A" D PATS^AMHGEGP(AMHREC,.PATS)
S @RETVAL@(AMHI)="T00030Result"_$C(30)
S AMHI=AMHI+1
S @RETVAL@(AMHI)=$S($G(AMHER)]"":AMHER,1:AMHREC)_$C(30)
S @RETVAL@(AMHI+1)=$C(31)
Q
;
POV(RETVAL,AMHSTR) ;-- save POV
S X="MERR^AMHGU",@^%ZOSF("TRAP") ; m error trap
N AMHI,P,R,AMHDM,AMHREC,AMHPV,AMHP,AMHER,APV
S P="|",R="~"
S RETVAL="^AMHTMP("_$J_")"
S AMHI=0
K ^AMHTMP($J)
I $G(AMHSTR)="" D CATSTR^AMHGU(.AMHSTR,.AMHSTR)
S AMHDM=$P(AMHSTR,P)
S AMHREC=$P(AMHSTR,P,2)
S AMHPV=$P(AMHSTR,P,3)
S AMHP=$P(AMHSTR,P,4)
D ARRAY^AMHGU(.APV,AMHPV)
D POV^AMHGEGP(AMHDM,AMHREC,AMHP,.APV)
S @RETVAL@(AMHI)="T00030Result"_$C(30)
S AMHI=AMHI+1
S @RETVAL@(AMHI)=$S($G(AMHER)]"":AMHER,1:AMHREC)_$C(30)
S @RETVAL@(AMHI+1)=$C(31)
Q
;
CPT(RETVAL,AMHSTR) ;-- save CPT
S X="MERR^AMHGU",@^%ZOSF("TRAP") ; m error trap
N AMHI,P,R,AMHDM,AMHREC,AMHCPT,AMHP,AMHER
S P="|",R="~"
S RETVAL="^AMHTMP("_$J_")"
S AMHI=0
K ^AMHTMP($J)
I $G(AMHSTR)="" D CATSTR^AMHGU(.AMHSTR,.AMHSTR)
S AMHDM=$P(AMHSTR,P)
S AMHREC=$P(AMHSTR,P,2)
S AMHCPT=$P(AMHSTR,P,3)
S AMHP=$P(AMHSTR,P,4)
N ACPT
D ARRAY^AMHGU(.ACPT,.AMHCPT)
N AMHDA
S AMHDA=0 F S AMHDA=$O(ACPT(AMHDA)) Q:'AMHDA D
. N CPT
. S CPT=+$G(ACPT(AMHDA))
. S QTY=+$P(ACPT(AMHDA),R,4)
. I QTY<1 S QTY=1
. S MOD1=$P(ACPT(AMHDA),R,5)
. S MOD2=$P(ACPT(AMHDA),R,7)
. D MODCPT^AMHGEVF(CPT,QTY,MOD1,MOD2,AMHP,AMHREC)
I AMHDM="E" D DELCPT^AMHGEVF(AMHREC,.ACPT)
S @RETVAL@(AMHI)="T00030Result"_$C(30)
S AMHI=AMHI+1
S @RETVAL@(AMHI)=$S($G(AMHER)]"":AMHER,1:AMHREC)_$C(30)
S @RETVAL@(AMHI+1)=$C(31)
Q
;
MH(RETVAL,AMHSTR) ;-- save MHSS records
S X="MERR^AMHGU",@^%ZOSF("TRAP") ; m error trap
N AMHI,P,R,AMHDM,AMHREC,AMHMH,AMHP,MH,AMHER
S P="|",R="~"
S RETVAL="^AMHTMP("_$J_")"
S AMHI=0
K ^AMHTMP($J)
I $G(AMHSTR)="" D CATSTR^AMHGU(.AMHSTR,.AMHSTR)
S AMHDM=$P(AMHSTR,P)
S AMHREC=$P(AMHSTR,P,2)
S AMHMH=$P(AMHSTR,P,3)
D ARRAY^AMHGU(.MH,AMHMH)
D MH^AMHGEGP(AMHREC,.MH)
S @RETVAL@(AMHI)="T00030Result"_$C(30)
S AMHI=AMHI+1
S @RETVAL@(AMHI)=$S($G(AMHER)]"":AMHER,1:AMHREC)_$C(30)
S @RETVAL@(AMHI+1)=$C(31)
Q
;
PNCA(RETVAL,AMHSTR) ;-- save progress notes/comment next appointment
S X="MERR^AMHGU",@^%ZOSF("TRAP") ; m error trap
N AMHI,P,R,AMHDM,AMHREC,AMHPN,AMHCA,AMHP,AMHER,AMHCC
S P="|",R="~"
S RETVAL="^AMHTMP("_$J_")"
S AMHI=0
K ^AMHTMP($J)
I $G(AMHSTR)="" D CATSTR^AMHGU(.AMHSTR,.AMHSTR)
S AMHDM=$P(AMHSTR,P)
S AMHREC=$P(AMHSTR,P,2)
S AMHPN=$P(AMHSTR,P,3)
S AMHCA=$P(AMHSTR,P,4)
S AMHP=$P(AMHSTR,P,5)
S AMHCC=$P(AMHSTR,P,6)
I $G(AMHDM)="A" S $P(^AMHREC(AMHREC,21),U)=AMHCC
D PN^AMHGEVF(AMHDM,AMHREC,AMHPN,AMHP)
D CMT^AMHGEVF(AMHDM,AMHREC,AMHCA,AMHP)
S @RETVAL@(AMHI)="T00030Result"_$C(30)
S AMHI=AMHI+1
S @RETVAL@(AMHI)=$S($G(AMHER)]"":AMHER,1:AMHREC)_$C(30)
S @RETVAL@(AMHI+1)=$C(31)
Q
;
DEL(RETVAL,AMHSTR) ;-- mark a record as deleted
S X="MERR^AMHGU",@^%ZOSF("TRAP") ; m error trap
N AMHI,P,R,AMHDM,AMHREC,AMHER
S P="|",R="~"
S RETVAL="^AMHTMP("_$J_")"
S AMHI=0
I $G(AMHSTR)="" D CATSTR^AMHGU(.AMHSTR,.AMHSTR)
K ^AMHTMP($J)
S AMHREC=$P(AMHSTR,P)
;D DELI(AMHREC)
S DIK="^AMHGROUP(",DA=AMHREC D ^DIK
S @RETVAL@(AMHI)="T00030Result"_$C(30)
S AMHI=AMHI+1
S @RETVAL@(AMHI)=$S($G(AMHER)]"":AMHER,1:AMHREC)_$C(30)
S @RETVAL@(AMHI+1)=$C(31)
Q
;
DELI(REC) ;-- delete each individual entry first
N RDA
S RDA=0 F S RDA=$O(^AMHGROUP(REC,61,RDA)) Q:'RDA D
. N IREC
. S IREC=$G(^AMHGROUP(REC,61,RDA,0))
. D EN^AMHGVDEL(.IREC,IREC)
Q
;
AMHGSGP ; 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("GP^AMHGSGP(.RETVAL,.AMHSTR)")
+2 QUIT
+3 ;
GP(RETVAL,AMHSTR) ;-- save group data
+1 ; m error trap
SET X="MERR^AMHGU"
SET @^%ZOSF("TRAP")
+2 NEW AMHI,P,R,AMHDM,AMHREC,AMHPP,AMHPRG,AMHGN,AMHCL,AMNNS,AMHTOC,AMHEL,AMHED,AMHCS,AMHACT,AMHAT,AMHSP,AMHPV,AMHPRGN,AMHCPT,AMHEDU,AMHPATS,AMHER,AMHCC
+3 NEW PV,CPT,EDU,PATS
+4 SET P="|"
SET R="~"
+5 SET RETVAL="^AMHTMP("_$JOB_")"
+6 SET AMHI=0
+7 KILL ^AMHTMP($JOB)
+8 IF $GET(AMHSTR)=""
DO CATSTR^AMHGU(.AMHSTR,.AMHSTR)
+9 SET AMHDM=$PIECE(AMHSTR,P)
+10 SET AMHREC=$PIECE(AMHSTR,P,2)
+11 SET AMHPP=$PIECE(AMHSTR,P,3)
+12 SET AMHPRG=$$SCI^AMHGT(9002011.67,.02,$PIECE(AMHSTR,P,4))
+13 SET AMHGN=$PIECE(AMHSTR,P,5)
+14 SET AMHCL=$PIECE(AMHSTR,P,6)
+15 SET AMHNS=$PIECE(AMHSTR,P,7)
+16 SET AMHTOC=$PIECE(AMHSTR,P,8)
+17 SET AMHEL=$PIECE(AMHSTR,P,9)
+18 SET AMHED=+$PIECE(AMHSTR,P,10)
+19 SET AMHCS=$PIECE(AMHSTR,P,11)
+20 SET AMHACT=$PIECE(AMHSTR,P,12)
+21 SET AMHAT=$PIECE(AMHSTR,P,13)
+22 SET AMHSP=$PIECE(AMHSTR,P,14)
+23 SET AMHPV=$PIECE(AMHSTR,P,15)
+24 SET AMHPRGN=$PIECE(AMHSTR,P,16)
+25 SET AMHCPT=$PIECE(AMHSTR,P,17)
+26 SET AMHEDU=$PIECE(AMHSTR,P,18)
+27 SET AMHPATS=$PIECE(AMHSTR,P,19)
+28 SET AMHCC=$PIECE(AMHSTR,P,20)
+29 DO ARRAY^AMHGU(.PV,AMHPV)
+30 DO ARRAY^AMHGU(.CPT,AMHCPT)
+31 DO ARRAY^AMHGU(.EDU,AMHEDU)
+32 DO ARRAY^AMHGU(.PATS,AMHPATS)
+33 DO GP^AMHGEGP(.AMHREC,AMHDM,AMHREC,AMHPRG,AMHGN,AMHCL,AMHNS,AMHTOC,AMHEL,AMHED,AMHCS,AMHACT,AMHAT,AMHCC)
+34 IF $GET(AMHER)=""
DO CLNPRV^AMHGEGP(AMHREC)
+35 IF $GET(AMHER)=""
DO MODPRV^AMHGEGP(AMHPP,AMHDM,AMHREC,"","P")
+36 ;v4.0p2 ihs/cmi/maw modified all below to not file if in edit mode
+37 IF $GET(AMHER)=""
IF AMHDM="A"
DO SP^AMHGEGP(AMHDM,AMHREC,"",AMHSP)
+38 IF $GET(AMHER)=""
IF AMHDM="A"
DO GPOV^AMHGEGP(AMHDM,AMHREC,.PV)
+39 IF $GET(AMHER)=""
IF AMHDM="A"
DO PN^AMHGEGP(AMHDM,AMHREC,AMHPRGN,"")
+40 IF $GET(AMHER)=""
IF AMHDM="A"
DO CPT^AMHGEGP(AMHREC,.CPT)
+41 IF $GET(AMHER)=""
IF AMHDM="A"
DO EDU^AMHGEGP(AMHREC,.EDU)
+42 IF $GET(AMHER)=""
IF AMHDM="A"
DO PATS^AMHGEGP(AMHREC,.PATS)
+43 SET @RETVAL@(AMHI)="T00030Result"_$CHAR(30)
+44 SET AMHI=AMHI+1
+45 SET @RETVAL@(AMHI)=$SELECT($GET(AMHER)]"":AMHER,1:AMHREC)_$CHAR(30)
+46 SET @RETVAL@(AMHI+1)=$CHAR(31)
+47 QUIT
+48 ;
POV(RETVAL,AMHSTR) ;-- save POV
+1 ; m error trap
SET X="MERR^AMHGU"
SET @^%ZOSF("TRAP")
+2 NEW AMHI,P,R,AMHDM,AMHREC,AMHPV,AMHP,AMHER,APV
+3 SET P="|"
SET R="~"
+4 SET RETVAL="^AMHTMP("_$JOB_")"
+5 SET AMHI=0
+6 KILL ^AMHTMP($JOB)
+7 IF $GET(AMHSTR)=""
DO CATSTR^AMHGU(.AMHSTR,.AMHSTR)
+8 SET AMHDM=$PIECE(AMHSTR,P)
+9 SET AMHREC=$PIECE(AMHSTR,P,2)
+10 SET AMHPV=$PIECE(AMHSTR,P,3)
+11 SET AMHP=$PIECE(AMHSTR,P,4)
+12 DO ARRAY^AMHGU(.APV,AMHPV)
+13 DO POV^AMHGEGP(AMHDM,AMHREC,AMHP,.APV)
+14 SET @RETVAL@(AMHI)="T00030Result"_$CHAR(30)
+15 SET AMHI=AMHI+1
+16 SET @RETVAL@(AMHI)=$SELECT($GET(AMHER)]"":AMHER,1:AMHREC)_$CHAR(30)
+17 SET @RETVAL@(AMHI+1)=$CHAR(31)
+18 QUIT
+19 ;
CPT(RETVAL,AMHSTR) ;-- save CPT
+1 ; m error trap
SET X="MERR^AMHGU"
SET @^%ZOSF("TRAP")
+2 NEW AMHI,P,R,AMHDM,AMHREC,AMHCPT,AMHP,AMHER
+3 SET P="|"
SET R="~"
+4 SET RETVAL="^AMHTMP("_$JOB_")"
+5 SET AMHI=0
+6 KILL ^AMHTMP($JOB)
+7 IF $GET(AMHSTR)=""
DO CATSTR^AMHGU(.AMHSTR,.AMHSTR)
+8 SET AMHDM=$PIECE(AMHSTR,P)
+9 SET AMHREC=$PIECE(AMHSTR,P,2)
+10 SET AMHCPT=$PIECE(AMHSTR,P,3)
+11 SET AMHP=$PIECE(AMHSTR,P,4)
+12 NEW ACPT
+13 DO ARRAY^AMHGU(.ACPT,.AMHCPT)
+14 NEW AMHDA
+15 SET AMHDA=0
FOR
SET AMHDA=$ORDER(ACPT(AMHDA))
IF 'AMHDA
QUIT
Begin DoDot:1
+16 NEW CPT
+17 SET CPT=+$GET(ACPT(AMHDA))
+18 SET QTY=+$PIECE(ACPT(AMHDA),R,4)
+19 IF QTY<1
SET QTY=1
+20 SET MOD1=$PIECE(ACPT(AMHDA),R,5)
+21 SET MOD2=$PIECE(ACPT(AMHDA),R,7)
+22 DO MODCPT^AMHGEVF(CPT,QTY,MOD1,MOD2,AMHP,AMHREC)
End DoDot:1
+23 IF AMHDM="E"
DO DELCPT^AMHGEVF(AMHREC,.ACPT)
+24 SET @RETVAL@(AMHI)="T00030Result"_$CHAR(30)
+25 SET AMHI=AMHI+1
+26 SET @RETVAL@(AMHI)=$SELECT($GET(AMHER)]"":AMHER,1:AMHREC)_$CHAR(30)
+27 SET @RETVAL@(AMHI+1)=$CHAR(31)
+28 QUIT
+29 ;
MH(RETVAL,AMHSTR) ;-- save MHSS records
+1 ; m error trap
SET X="MERR^AMHGU"
SET @^%ZOSF("TRAP")
+2 NEW AMHI,P,R,AMHDM,AMHREC,AMHMH,AMHP,MH,AMHER
+3 SET P="|"
SET R="~"
+4 SET RETVAL="^AMHTMP("_$JOB_")"
+5 SET AMHI=0
+6 KILL ^AMHTMP($JOB)
+7 IF $GET(AMHSTR)=""
DO CATSTR^AMHGU(.AMHSTR,.AMHSTR)
+8 SET AMHDM=$PIECE(AMHSTR,P)
+9 SET AMHREC=$PIECE(AMHSTR,P,2)
+10 SET AMHMH=$PIECE(AMHSTR,P,3)
+11 DO ARRAY^AMHGU(.MH,AMHMH)
+12 DO MH^AMHGEGP(AMHREC,.MH)
+13 SET @RETVAL@(AMHI)="T00030Result"_$CHAR(30)
+14 SET AMHI=AMHI+1
+15 SET @RETVAL@(AMHI)=$SELECT($GET(AMHER)]"":AMHER,1:AMHREC)_$CHAR(30)
+16 SET @RETVAL@(AMHI+1)=$CHAR(31)
+17 QUIT
+18 ;
PNCA(RETVAL,AMHSTR) ;-- save progress notes/comment next appointment
+1 ; m error trap
SET X="MERR^AMHGU"
SET @^%ZOSF("TRAP")
+2 NEW AMHI,P,R,AMHDM,AMHREC,AMHPN,AMHCA,AMHP,AMHER,AMHCC
+3 SET P="|"
SET R="~"
+4 SET RETVAL="^AMHTMP("_$JOB_")"
+5 SET AMHI=0
+6 KILL ^AMHTMP($JOB)
+7 IF $GET(AMHSTR)=""
DO CATSTR^AMHGU(.AMHSTR,.AMHSTR)
+8 SET AMHDM=$PIECE(AMHSTR,P)
+9 SET AMHREC=$PIECE(AMHSTR,P,2)
+10 SET AMHPN=$PIECE(AMHSTR,P,3)
+11 SET AMHCA=$PIECE(AMHSTR,P,4)
+12 SET AMHP=$PIECE(AMHSTR,P,5)
+13 SET AMHCC=$PIECE(AMHSTR,P,6)
+14 IF $GET(AMHDM)="A"
SET $PIECE(^AMHREC(AMHREC,21),U)=AMHCC
+15 DO PN^AMHGEVF(AMHDM,AMHREC,AMHPN,AMHP)
+16 DO CMT^AMHGEVF(AMHDM,AMHREC,AMHCA,AMHP)
+17 SET @RETVAL@(AMHI)="T00030Result"_$CHAR(30)
+18 SET AMHI=AMHI+1
+19 SET @RETVAL@(AMHI)=$SELECT($GET(AMHER)]"":AMHER,1:AMHREC)_$CHAR(30)
+20 SET @RETVAL@(AMHI+1)=$CHAR(31)
+21 QUIT
+22 ;
DEL(RETVAL,AMHSTR) ;-- mark a record as deleted
+1 ; m error trap
SET X="MERR^AMHGU"
SET @^%ZOSF("TRAP")
+2 NEW AMHI,P,R,AMHDM,AMHREC,AMHER
+3 SET P="|"
SET R="~"
+4 SET RETVAL="^AMHTMP("_$JOB_")"
+5 SET AMHI=0
+6 IF $GET(AMHSTR)=""
DO CATSTR^AMHGU(.AMHSTR,.AMHSTR)
+7 KILL ^AMHTMP($JOB)
+8 SET AMHREC=$PIECE(AMHSTR,P)
+9 ;D DELI(AMHREC)
+10 SET DIK="^AMHGROUP("
SET DA=AMHREC
DO ^DIK
+11 SET @RETVAL@(AMHI)="T00030Result"_$CHAR(30)
+12 SET AMHI=AMHI+1
+13 SET @RETVAL@(AMHI)=$SELECT($GET(AMHER)]"":AMHER,1:AMHREC)_$CHAR(30)
+14 SET @RETVAL@(AMHI+1)=$CHAR(31)
+15 QUIT
+16 ;
DELI(REC) ;-- delete each individual entry first
+1 NEW RDA
+2 SET RDA=0
FOR
SET RDA=$ORDER(^AMHGROUP(REC,61,RDA))
IF 'RDA
QUIT
Begin DoDot:1
+3 NEW IREC
+4 SET IREC=$GET(^AMHGROUP(REC,61,RDA,0))
+5 DO EN^AMHGVDEL(.IREC,IREC)
End DoDot:1
+6 QUIT
+7 ;
