AMHGETP ; IHS/CMI/MAW - AMHG Treatment Plan Add/Edits 3/7/2009 8:49:18 PM ;
;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8
;
;
;
DEBUG(RETVAL,AMHSTR) ;-- debug entry point
D DEBUG^%Serenji("EP^AMHGD(RETVAL,.AMHSTR)")
Q
;
TP(AMHIEN,DM,REC,PAT,DE,PRG,TD,RD,DC,DP,A5,CA,CD,DS,PRBL,GAF,PP) ;EP -- file the treatment plan
N AMHIENS,AMHFDA,AMHERRR,FL
S AMHIENS=$S(DM="A":"+1,",1:REC_",")
S FL=9002011.56
S AMHFDA(FL,AMHIENS,.03)=TD
S AMHFDA(FL,AMHIENS,.04)=DP
S AMHFDA(FL,AMHIENS,.05)=DS
S AMHFDA(FL,AMHIENS,.06)=CD
S AMHFDA(FL,AMHIENS,.09)=RD
S AMHFDA(FL,AMHIENS,.12)=DC
S AMHFDA(FL,AMHIENS,.16)=CA
S AMHFDA(FL,AMHIENS,.17)=PRG
S AMHFDA(FL,AMHIENS,1601)=A5
S AMHFDA(FL,AMHIENS,1101)=PRBL
S AMHFDA(FL,AMHIENS,1602)=GAF
I DM="A" D
. S AMHFDA(FL,AMHIENS,.01)=DE
. S AMHFDA(FL,AMHIENS,.02)=PAT
. D UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
. I '$D(AMHERRR) S AMHIEN=$G(AMHIENS(1)) Q
. S AMHER="0~Add Treatment Plan"
I DM="E" D
. S AMHFDA(FL,AMHIENS,.01)=DE
. D FILE^DIE("K","AMHFDA","AMHERRR(1)")
. I '$D(AMHERRR) S AMHIEN=REC Q
. S AMHER="0~Edit Treatment Plan"
I $D(PP) D PPART(AMHIEN,.PP)
Q
ADDAXIS4(PI,RC) ;EP -- add axis 4
N AMHFDA,AMHIENS,AMHERRR,AMHAIEN
S AMHIENS="+2,"_RC_","
S AMHFDA(9002011.569,AMHIENS,.01)=PI
D UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
I $D(AMHERRR) S AMHER="0~Add Axis IV"
I '$D(AMHERRR) S AMHAIEN=$G(AMHIENS(1))
Q
;
DELAXIS4(REC,A4) ;EP -- check to see if any axis 4 records were deleted during edit
N ADA,R,A
S R="~"
S ADA=0 F S ADA=$O(A4(ADA)) Q:'ADA D
. N A4IEN
. S A4IEN=$P(A4(ADA),R)
. S A(A4IEN)=A4IEN
N IEN
S IEN=0 F S IEN=$O(^AMHPTXP(REC,9,IEN)) Q:'IEN D
. N AXIS4
. S AXIS4=$P(^AMHPTXP(REC,9,IEN,0),U)
. I '$G(A(AXIS4)) D
.. S DA(1)=REC,DA=IEN,DIK="^AMHPTXP("_DA(1)_",9," D ^DIK
Q
;
A(RC,A,FLD) ;EP -- file wp fields
;Q:$G(A)=""
N AMHWP
D ARRAYT^AMHGU(.AMHWP,A) ;parse the text into an array
N AMHFDA,AMHIENS,AMHERRR
S AMHIENS=RC_","
D WP^AMHGU(.AMHERRR,9002011.56,AMHIENS,FLD,.AMHWP)
Q
;
RD(REC,D,DP,DS) ;EP -- file review data
D CLNRV(REC)
N RDA,R
S R="~"
S RDA=0 F S RDA=$O(D(RDA)) Q:'RDA D
. N RSTR,RRD,RRP,RRS,RNRD,RRPI,RRSI
. S RSTR=$G(D(RDA))
. S RRD=$P(RSTR,R)
. S RRP=$P(RSTR,R,2)
. S RRPI=$S($G(RRP)]"":$O(^VA(200,"B",RRP,0)),1:"")
. S RRS=$P(RSTR,R,3)
. S RRSI=$S($G(RRS)]"":$O(^VA(200,"B",RRS,0)),1:"")
. S RNRD=$P(RSTR,R,4)
. N AMHFDA,AMHIENS,AMHERRR,FL,AMHRDIEN
. S FL=9002011.564101
. S AMHIENS="+2,"_REC_","
. S AMHIENS(2)=RRD
. S AMHFDA(FL,AMHIENS,.01)=RRD
. S AMHFDA(FL,AMHIENS,.02)=RNRD
. S AMHFDA(FL,AMHIENS,.03)=RRPI
. S AMHFDA(FL,AMHIENS,.04)=RRSI
. D UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
. I '$D(AMHERRR) S AMHRDIEN=$G(AMHIENS(2))
. I $G(DP(RDA))]"",$E(DP(RDA),1,1)'=" " D PART(REC,AMHRDIEN,.DP,RDA)
. I $G(DS(RDA))]"",$E(DS(RDA),1,1)'=" " D PS(REC,AMHRDIEN,1,DS(RDA))
Q
;
PART(RC,DIEN,DP,RA) ;-- file the participants
N PFL
;Q:$E(DP(DIEN),1,1)=" "
S PFL=9002011.574112
N PDA,I
F I=1:1 D Q:$P(DP(RA),"&",I)=""
. Q:$P(DP(RA),"&",I)=""
. N PSTR,PART,REL
. S PSTR=$P(DP(RA),"&",I)
. S PART=$P(PSTR,"~")
. S REL=$P(PSTR,"~",2)
. N AMHPFDA,AMHPERR,AMHPIENS
. S AMHPIENS="+3,"_DIEN_","_RC_","
. S AMHPFDA(PFL,AMHPIENS,.01)=PART
. S AMHPFDA(PFL,AMHPIENS,.02)=REL
. D UPDATE^DIE("","AMHPFDA","AMHPIENS","AMHPERR(1)")
. I '$D(AMHPERR) S AMHPIEN=$G(AMHIENS(3))
Q
;
PPART(RC,PP) ;-- file the plan participants
D CLNPP(RC)
N PFL
;Q:$E(DP(DIEN),1,1)=" "
S PFL=9002011.561701
N PDA,I
S PDA=0 F S PDA=$O(PP(PDA)) Q:'PDA D
. N PSTR,PART,REL
. S PSTR=$G(PP(PDA))
. S PART=$P(PSTR,"~")
. S REL=$P(PSTR,"~",2)
. N AMHPFDA,AMHPERR,AMHPIENS
. S AMHPIENS="+2,"_RC_","
. S AMHPFDA(PFL,AMHPIENS,.01)=PART
. S AMHPFDA(PFL,AMHPIENS,.02)=REL
. D UPDATE^DIE("","AMHPFDA","AMHPIENS","AMHPERR(1)")
. I '$D(AMHPERR) S AMHPIEN=$G(AMHIENS(2))
Q
;
PS(RC,DIEN,FLD,DS) ;-- file the progress summary
;TODO nned to find out how to file a WP field in a subfile
S AMHIENS(2)=DIEN
S AMHIENS(1)=RC
Q:$G(DS)=""
N AMHWP
D ARRAYT^AMHGU(.AMHWP,DS) ;parse the text into an array
;N AMHSFDA,AMHSIENS,AMHSERR
N PSDA,CNT
S CNT=0
S PSDA=0 F S PSDA=$O(AMHWP(PSDA)) Q:'PSDA D
. S CNT=CNT+1
. S ^AMHPTXP(RC,41,DIEN,1,PSDA,0)=$G(AMHWP(PSDA))
S ^AMHPTXP(RC,41,DIEN,1,0)="^^"_CNT_"^"_CNT_"^"_DIEN_"^"
;S AMHSIENS="+3,"_DIEN_","_RC_","
;D WP^AMHGU(.AMHERRR,9002011.56411,AMHIENS,FLD,.AMHWP)
Q
;
CLNPP(RC) ;-- clean out plan participants
S DA(1)=RC
S DIK="^AMHPTXP("_DA(1)_",17,"
N PDA
S PDA=0 F S PDA=$O(^AMHPTXP(RC,17,PDA)) Q:'PDA D
. S DA=PDA
. D ^DIK
Q
;
CLNRV(RC) ;clean out the review data first
S DA(1)=RC
S DIK="^AMHPTXP("_DA(1)_",41,"
N TDA
S TDA=0 F S TDA=$O(^AMHPTXP(RC,41,TDA)) Q:'TDA D
. S DA=TDA
. D ^DIK
Q
;
AMHGETP ; IHS/CMI/MAW - AMHG Treatment Plan Add/Edits 3/7/2009 8:49:18 PM ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8
+2 ;
+3 ;
+4 ;
DEBUG(RETVAL,AMHSTR) ;-- debug entry point
+1 DO DEBUG^%Serenji("EP^AMHGD(RETVAL,.AMHSTR)")
+2 QUIT
+3 ;
TP(AMHIEN,DM,REC,PAT,DE,PRG,TD,RD,DC,DP,A5,CA,CD,DS,PRBL,GAF,PP) ;EP -- file the treatment plan
+1 NEW AMHIENS,AMHFDA,AMHERRR,FL
+2 SET AMHIENS=$SELECT(DM="A":"+1,",1:REC_",")
+3 SET FL=9002011.56
+4 SET AMHFDA(FL,AMHIENS,.03)=TD
+5 SET AMHFDA(FL,AMHIENS,.04)=DP
+6 SET AMHFDA(FL,AMHIENS,.05)=DS
+7 SET AMHFDA(FL,AMHIENS,.06)=CD
+8 SET AMHFDA(FL,AMHIENS,.09)=RD
+9 SET AMHFDA(FL,AMHIENS,.12)=DC
+10 SET AMHFDA(FL,AMHIENS,.16)=CA
+11 SET AMHFDA(FL,AMHIENS,.17)=PRG
+12 SET AMHFDA(FL,AMHIENS,1601)=A5
+13 SET AMHFDA(FL,AMHIENS,1101)=PRBL
+14 SET AMHFDA(FL,AMHIENS,1602)=GAF
+15 IF DM="A"
Begin DoDot:1
+16 SET AMHFDA(FL,AMHIENS,.01)=DE
+17 SET AMHFDA(FL,AMHIENS,.02)=PAT
+18 DO UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
+19 IF '$DATA(AMHERRR)
SET AMHIEN=$GET(AMHIENS(1))
QUIT
+20 SET AMHER="0~Add Treatment Plan"
End DoDot:1
+21 IF DM="E"
Begin DoDot:1
+22 SET AMHFDA(FL,AMHIENS,.01)=DE
+23 DO FILE^DIE("K","AMHFDA","AMHERRR(1)")
+24 IF '$DATA(AMHERRR)
SET AMHIEN=REC
QUIT
+25 SET AMHER="0~Edit Treatment Plan"
End DoDot:1
+26 IF $DATA(PP)
DO PPART(AMHIEN,.PP)
+27 QUIT
ADDAXIS4(PI,RC) ;EP -- add axis 4
+1 NEW AMHFDA,AMHIENS,AMHERRR,AMHAIEN
+2 SET AMHIENS="+2,"_RC_","
+3 SET AMHFDA(9002011.569,AMHIENS,.01)=PI
+4 DO UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
+5 IF $DATA(AMHERRR)
SET AMHER="0~Add Axis IV"
+6 IF '$DATA(AMHERRR)
SET AMHAIEN=$GET(AMHIENS(1))
+7 QUIT
+8 ;
DELAXIS4(REC,A4) ;EP -- check to see if any axis 4 records were deleted during edit
+1 NEW ADA,R,A
+2 SET R="~"
+3 SET ADA=0
FOR
SET ADA=$ORDER(A4(ADA))
IF 'ADA
QUIT
Begin DoDot:1
+4 NEW A4IEN
+5 SET A4IEN=$PIECE(A4(ADA),R)
+6 SET A(A4IEN)=A4IEN
End DoDot:1
+7 NEW IEN
+8 SET IEN=0
FOR
SET IEN=$ORDER(^AMHPTXP(REC,9,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+9 NEW AXIS4
+10 SET AXIS4=$PIECE(^AMHPTXP(REC,9,IEN,0),U)
+11 IF '$GET(A(AXIS4))
Begin DoDot:2
+12 SET DA(1)=REC
SET DA=IEN
SET DIK="^AMHPTXP("_DA(1)_",9,"
DO ^DIK
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
A(RC,A,FLD) ;EP -- file wp fields
+1 ;Q:$G(A)=""
+2 NEW AMHWP
+3 ;parse the text into an array
DO ARRAYT^AMHGU(.AMHWP,A)
+4 NEW AMHFDA,AMHIENS,AMHERRR
+5 SET AMHIENS=RC_","
+6 DO WP^AMHGU(.AMHERRR,9002011.56,AMHIENS,FLD,.AMHWP)
+7 QUIT
+8 ;
RD(REC,D,DP,DS) ;EP -- file review data
+1 DO CLNRV(REC)
+2 NEW RDA,R
+3 SET R="~"
+4 SET RDA=0
FOR
SET RDA=$ORDER(D(RDA))
IF 'RDA
QUIT
Begin DoDot:1
+5 NEW RSTR,RRD,RRP,RRS,RNRD,RRPI,RRSI
+6 SET RSTR=$GET(D(RDA))
+7 SET RRD=$PIECE(RSTR,R)
+8 SET RRP=$PIECE(RSTR,R,2)
+9 SET RRPI=$SELECT($GET(RRP)]"":$ORDER(^VA(200,"B",RRP,0)),1:"")
+10 SET RRS=$PIECE(RSTR,R,3)
+11 SET RRSI=$SELECT($GET(RRS)]"":$ORDER(^VA(200,"B",RRS,0)),1:"")
+12 SET RNRD=$PIECE(RSTR,R,4)
+13 NEW AMHFDA,AMHIENS,AMHERRR,FL,AMHRDIEN
+14 SET FL=9002011.564101
+15 SET AMHIENS="+2,"_REC_","
+16 SET AMHIENS(2)=RRD
+17 SET AMHFDA(FL,AMHIENS,.01)=RRD
+18 SET AMHFDA(FL,AMHIENS,.02)=RNRD
+19 SET AMHFDA(FL,AMHIENS,.03)=RRPI
+20 SET AMHFDA(FL,AMHIENS,.04)=RRSI
+21 DO UPDATE^DIE("","AMHFDA","AMHIENS","AMHERRR(1)")
+22 IF '$DATA(AMHERRR)
SET AMHRDIEN=$GET(AMHIENS(2))
+23 IF $GET(DP(RDA))]""
IF $EXTRACT(DP(RDA),1,1)'=" "
DO PART(REC,AMHRDIEN,.DP,RDA)
+24 IF $GET(DS(RDA))]""
IF $EXTRACT(DS(RDA),1,1)'=" "
DO PS(REC,AMHRDIEN,1,DS(RDA))
End DoDot:1
+25 QUIT
+26 ;
PART(RC,DIEN,DP,RA) ;-- file the participants
+1 NEW PFL
+2 ;Q:$E(DP(DIEN),1,1)=" "
+3 SET PFL=9002011.574112
+4 NEW PDA,I
+5 FOR I=1:1
Begin DoDot:1
+6 IF $PIECE(DP(RA),"&",I)=""
QUIT
+7 NEW PSTR,PART,REL
+8 SET PSTR=$PIECE(DP(RA),"&",I)
+9 SET PART=$PIECE(PSTR,"~")
+10 SET REL=$PIECE(PSTR,"~",2)
+11 NEW AMHPFDA,AMHPERR,AMHPIENS
+12 SET AMHPIENS="+3,"_DIEN_","_RC_","
+13 SET AMHPFDA(PFL,AMHPIENS,.01)=PART
+14 SET AMHPFDA(PFL,AMHPIENS,.02)=REL
+15 DO UPDATE^DIE("","AMHPFDA","AMHPIENS","AMHPERR(1)")
+16 IF '$DATA(AMHPERR)
SET AMHPIEN=$GET(AMHIENS(3))
End DoDot:1
IF $PIECE(DP(RA),"&",I)=""
QUIT
+17 QUIT
+18 ;
PPART(RC,PP) ;-- file the plan participants
+1 DO CLNPP(RC)
+2 NEW PFL
+3 ;Q:$E(DP(DIEN),1,1)=" "
+4 SET PFL=9002011.561701
+5 NEW PDA,I
+6 SET PDA=0
FOR
SET PDA=$ORDER(PP(PDA))
IF 'PDA
QUIT
Begin DoDot:1
+7 NEW PSTR,PART,REL
+8 SET PSTR=$GET(PP(PDA))
+9 SET PART=$PIECE(PSTR,"~")
+10 SET REL=$PIECE(PSTR,"~",2)
+11 NEW AMHPFDA,AMHPERR,AMHPIENS
+12 SET AMHPIENS="+2,"_RC_","
+13 SET AMHPFDA(PFL,AMHPIENS,.01)=PART
+14 SET AMHPFDA(PFL,AMHPIENS,.02)=REL
+15 DO UPDATE^DIE("","AMHPFDA","AMHPIENS","AMHPERR(1)")
+16 IF '$DATA(AMHPERR)
SET AMHPIEN=$GET(AMHIENS(2))
End DoDot:1
+17 QUIT
+18 ;
PS(RC,DIEN,FLD,DS) ;-- file the progress summary
+1 ;TODO nned to find out how to file a WP field in a subfile
+2 SET AMHIENS(2)=DIEN
+3 SET AMHIENS(1)=RC
+4 IF $GET(DS)=""
QUIT
+5 NEW AMHWP
+6 ;parse the text into an array
DO ARRAYT^AMHGU(.AMHWP,DS)
+7 ;N AMHSFDA,AMHSIENS,AMHSERR
+8 NEW PSDA,CNT
+9 SET CNT=0
+10 SET PSDA=0
FOR
SET PSDA=$ORDER(AMHWP(PSDA))
IF 'PSDA
QUIT
Begin DoDot:1
+11 SET CNT=CNT+1
+12 SET ^AMHPTXP(RC,41,DIEN,1,PSDA,0)=$GET(AMHWP(PSDA))
End DoDot:1
+13 SET ^AMHPTXP(RC,41,DIEN,1,0)="^^"_CNT_"^"_CNT_"^"_DIEN_"^"
+14 ;S AMHSIENS="+3,"_DIEN_","_RC_","
+15 ;D WP^AMHGU(.AMHERRR,9002011.56411,AMHIENS,FLD,.AMHWP)
+16 QUIT
+17 ;
CLNPP(RC) ;-- clean out plan participants
+1 SET DA(1)=RC
+2 SET DIK="^AMHPTXP("_DA(1)_",17,"
+3 NEW PDA
+4 SET PDA=0
FOR
SET PDA=$ORDER(^AMHPTXP(RC,17,PDA))
IF 'PDA
QUIT
Begin DoDot:1
+5 SET DA=PDA
+6 DO ^DIK
End DoDot:1
+7 QUIT
+8 ;
CLNRV(RC) ;clean out the review data first
+1 SET DA(1)=RC
+2 SET DIK="^AMHPTXP("_DA(1)_",41,"
+3 NEW TDA
+4 SET TDA=0
FOR
SET TDA=$ORDER(^AMHPTXP(RC,41,TDA))
IF 'TDA
QUIT
Begin DoDot:1
+5 SET DA=TDA
+6 DO ^DIK
End DoDot:1
+7 QUIT
+8 ;
