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