TIULQ ; SLC/JER - Record Extract Using FM Retriever ; 3/1/06 3:46pm
;;1.0;TEXT INTEGRATION UTILITIES;**19,100,157,211**;Jun 20, 1997;Build 26
; Do we need a new DBIA here? MARGY
N DA,DIC,DIQ,TIULQ,X,Y
S TIUROOT=$G(TIUROOT,"^TMP(""TIULQ"",$J)")
S DA=TIUDA,DIC=8925,DIQ="TIULQ",DIQ(0)=$G(FORMAT,"IE")
I $G(DR)']"" S DR=".01:.1;1201:1701;89261"
D EN^DIQ1
I '$D(TIULQ) S TIUERR="1^ Record Extract Failed"
M @TIUROOT@(TIUDA)=TIULQ(8925,TIUDA)
D XTRASIGN(DA,+$G(TIULINE))
D PROBLEMS(DA,+$G(TIULINE))
I +$G(TIUTEXT) D TEXT(TIUDA,+$G(TIULINE),TIUDA,+$G(OVRRIDE),+$G(ORIGCHLD))
Q
XTRASIGN(TIUDA,TIUJ) ; Get Extra Signers
N TIUI,TIUXTRA,TIUC,DR,DIC,DIQ S TIUI=0
F S TIUI=$O(^TIU(8925.7,"B",+TIUDA,TIUI)) Q:+TIUI'>0 D
. N TIUDT,TIUSGN,TIUSNM,TIUSTTL,TIUEIEN,TIUENAME
. S DA=TIUI,DR=".03:.07",DIC="^TIU(8925.7,",DIQ="TIUXTRA",DIQ(0)="IE"
. D EN^DIQ1 Q:$D(TIUXTRA)'>9
. S TIUC=+$G(TIUC)+1
. S TIUEIEN=$G(TIUXTRA(8925.7,DA,.03,"I"))
. S TIUENAME=$G(TIUXTRA(8925.7,DA,.03,"E"))
. S TIUDT=$G(TIUXTRA(8925.7,DA,.04,"I"))
. S TIUSGN=$G(TIUXTRA(8925.7,DA,.05,"I"))
. S TIUSNM=$G(TIUXTRA(8925.7,DA,.06,"E"))
. S TIUSTTL=$G(TIUXTRA(8925.7,DA,.07,"E"))
. S @TIUROOT@(TIUDA,"EXTRASGNR",(TIUJ+TIUC),"EXPIEN")=TIUEIEN
. S @TIUROOT@(TIUDA,"EXTRASGNR",(TIUJ+TIUC),"EXPNAME")=TIUENAME
. S @TIUROOT@(TIUDA,"EXTRASGNR",(TIUJ+TIUC),"DATE")=TIUDT
. S @TIUROOT@(TIUDA,"EXTRASGNR",(TIUJ+TIUC),"EXTRA")=TIUSGN
. S @TIUROOT@(TIUDA,"EXTRASGNR",(TIUJ+TIUC),"NAME")=TIUSNM
. S @TIUROOT@(TIUDA,"EXTRASGNR",(TIUJ+TIUC),"TITLE")=TIUSTTL
Q
PROBLEMS(TIUDA,TIUJ) ; Get associated problems
N TIUI,TIUP,TIUPROB,TIUC,TIUX,DR,DIC,DIQ S TIUI=0
F S TIUI=$O(^TIU(8925.9,"B",+TIUDA,TIUI)) Q:+TIUI'>0 D
. S DA=TIUI,DR=".02;.05",DIC="^TIU(8925.9,",DIQ="TIUPROB"
. D EN^DIQ1 Q:$D(TIUPROB)'>9
. S TIUC=+$G(TIUC)+1
. S TIUP=$$MIXED^TIULS($G(TIUPROB(8925.9,TIUI,.05)))
. S TIUX=$$SETSTR^VALM1($J(TIUC,2)_".",$G(TIUX),1,3)
. S TIUX=$$SETSTR^VALM1(TIUP,$G(TIUX),5,35)
. S TIUP=$G(TIUPROB(8925.9,TIUI,.02))
. S TIUX=$$SETSTR^VALM1(TIUP,$G(TIUX),40,6)
. S @TIUROOT@(TIUDA,"PROBLEM",(TIUJ+TIUC),0)=TIUX
Q
TEXT(TIUDA,TIUJ,TIUDAD,TIUOVR,ORIGCHLD) ; Get each component
N TIUKID,TIUDADT,TIUI,TIUD0,TIULVL,CANPRINT S TIUI=0
S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIULVL=$P($G(^TIU(8925.1,+TIUD0,0)),U,4)
S CANPRINT=$S(TIULVL="DOC":$$CANDO^TIULP(TIUDA,"PRINT RECORD"),1:1)
I +TIUOVR'>0,(+CANPRINT'>0) D Q
. S TIUJ=+$G(TIUJ)+1
. S @TIUROOT@(TIUDAD,"TEXT",TIUJ,0)=$P(CANPRINT,U,2)
. S @TIUROOT@(TIUDAD,"TEXT",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
F S TIUI=$O(^TIU(8925,+TIUDA,"TEXT",TIUI)) Q:+TIUI'>0 D
. S TIUJ=+$G(TIUJ)+1
. S @TIUROOT@(TIUDAD,"TEXT",TIUJ,0)=$G(^TIU(8925,+TIUDA,"TEXT",TIUI,0))
S @TIUROOT@(TIUDAD,"TEXT",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
; Iterate through children, and get their text fields
S TIUKID=0
F S TIUKID=$O(^TIU(8925,"DAD",+TIUDA,TIUKID)) Q:+TIUKID'>0 D
. I +$$ISADDNDM^TIULC1(TIUKID) D
. . N TIUADRT
. . I TIUROOT[")" S TIUADRT=$P(TIUROOT,")")_","_TIUDAD_",""ZADD"")"
. . E S TIUADRT=TIUROOT_"("_TIUDAD_",""ZADD"")"
. . D EXTRACT(TIUKID,TIUADRT,.TIUERR,DR,.TIUJ,1) I 1
. E D TEXT(TIUKID,.TIUJ,TIUDAD,+$G(TIUOVR))
; Get ID kids in correct sort order; extract data for each kid:
Q:'$O(^TIU(8925,"GDAD",TIUDA,0))
N TIUGDATA,TIUSORT,TIUK,TIUIDKID,TIUIDRT,CTR
S TIUGDATA=$$IDDATA^TIURECL1(TIUDA)
S TIUSORT=$P(TIUGDATA,U,4)
D GETIDKID^TIURECL2(TIUDA,TIUSORT)
S TIUK=0,CTR=0
F S TIUK=$O(^TMP("TIUIDKID",$J,TIUDA,TIUK)) Q:'TIUK D
. S TIUIDKID=^TMP("TIUIDKID",$J,TIUDA,TIUK)
. N TIUIDRT
. I TIUROOT[")" S TIUIDRT=$P(TIUROOT,")")_","_TIUDAD_",""ZZID"","_TIUK_")"
. E S TIUIDRT=TIUROOT_"("_TIUDAD_",""ZZID"","_TIUK_")"
. D EXTRACT(TIUIDKID,TIUIDRT,.TIUERR,DR,.TIUJ,1)
. S CTR=CTR+1
I CTR S @TIUROOT@(TIUDAD,"ZZID",0)=CTR ; How many ID kids TIUDAD has
;I CTR,$G(ORIGCHLD) S @TIUROOT@(TIUDAD,"REASON")="Note included because interdisciplinary child meets criteria."
K ^TMP("TIUIDKID",$J)
Q
TIULQ ; SLC/JER - Record Extract Using FM Retriever ; 3/1/06 3:46pm
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**19,100,157,211**;Jun 20, 1997;Build 26
+1 ; Do we need a new DBIA here? MARGY
+2 NEW DA,DIC,DIQ,TIULQ,X,Y
+3 SET TIUROOT=$GET(TIUROOT,"^TMP(""TIULQ"",$J)")
+4 SET DA=TIUDA
SET DIC=8925
SET DIQ="TIULQ"
SET DIQ(0)=$GET(FORMAT,"IE")
+5 IF $GET(DR)']""
SET DR=".01:.1;1201:1701;89261"
+6 DO EN^DIQ1
+7 IF '$DATA(TIULQ)
SET TIUERR="1^ Record Extract Failed"
+8 MERGE @TIUROOT@(TIUDA)=TIULQ(8925,TIUDA)
+9 DO XTRASIGN(DA,+$GET(TIULINE))
+10 DO PROBLEMS(DA,+$GET(TIULINE))
+11 IF +$GET(TIUTEXT)
DO TEXT(TIUDA,+$GET(TIULINE),TIUDA,+$GET(OVRRIDE),+$GET(ORIGCHLD))
+12 QUIT
XTRASIGN(TIUDA,TIUJ) ; Get Extra Signers
+1 NEW TIUI,TIUXTRA,TIUC,DR,DIC,DIQ
SET TIUI=0
+2 FOR
SET TIUI=$ORDER(^TIU(8925.7,"B",+TIUDA,TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:1
+3 NEW TIUDT,TIUSGN,TIUSNM,TIUSTTL,TIUEIEN,TIUENAME
+4 SET DA=TIUI
SET DR=".03:.07"
SET DIC="^TIU(8925.7,"
SET DIQ="TIUXTRA"
SET DIQ(0)="IE"
+5 DO EN^DIQ1
IF $DATA(TIUXTRA)'>9
QUIT
+6 SET TIUC=+$GET(TIUC)+1
+7 SET TIUEIEN=$GET(TIUXTRA(8925.7,DA,.03,"I"))
+8 SET TIUENAME=$GET(TIUXTRA(8925.7,DA,.03,"E"))
+9 SET TIUDT=$GET(TIUXTRA(8925.7,DA,.04,"I"))
+10 SET TIUSGN=$GET(TIUXTRA(8925.7,DA,.05,"I"))
+11 SET TIUSNM=$GET(TIUXTRA(8925.7,DA,.06,"E"))
+12 SET TIUSTTL=$GET(TIUXTRA(8925.7,DA,.07,"E"))
+13 SET @TIUROOT@(TIUDA,"EXTRASGNR",(TIUJ+TIUC),"EXPIEN")=TIUEIEN
+14 SET @TIUROOT@(TIUDA,"EXTRASGNR",(TIUJ+TIUC),"EXPNAME")=TIUENAME
+15 SET @TIUROOT@(TIUDA,"EXTRASGNR",(TIUJ+TIUC),"DATE")=TIUDT
+16 SET @TIUROOT@(TIUDA,"EXTRASGNR",(TIUJ+TIUC),"EXTRA")=TIUSGN
+17 SET @TIUROOT@(TIUDA,"EXTRASGNR",(TIUJ+TIUC),"NAME")=TIUSNM
+18 SET @TIUROOT@(TIUDA,"EXTRASGNR",(TIUJ+TIUC),"TITLE")=TIUSTTL
End DoDot:1
+19 QUIT
PROBLEMS(TIUDA,TIUJ) ; Get associated problems
+1 NEW TIUI,TIUP,TIUPROB,TIUC,TIUX,DR,DIC,DIQ
SET TIUI=0
+2 FOR
SET TIUI=$ORDER(^TIU(8925.9,"B",+TIUDA,TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:1
+3 SET DA=TIUI
SET DR=".02;.05"
SET DIC="^TIU(8925.9,"
SET DIQ="TIUPROB"
+4 DO EN^DIQ1
IF $DATA(TIUPROB)'>9
QUIT
+5 SET TIUC=+$GET(TIUC)+1
+6 SET TIUP=$$MIXED^TIULS($GET(TIUPROB(8925.9,TIUI,.05)))
+7 SET TIUX=$$SETSTR^VALM1($JUSTIFY(TIUC,2)_".",$GET(TIUX),1,3)
+8 SET TIUX=$$SETSTR^VALM1(TIUP,$GET(TIUX),5,35)
+9 SET TIUP=$GET(TIUPROB(8925.9,TIUI,.02))
+10 SET TIUX=$$SETSTR^VALM1(TIUP,$GET(TIUX),40,6)
+11 SET @TIUROOT@(TIUDA,"PROBLEM",(TIUJ+TIUC),0)=TIUX
End DoDot:1
+12 QUIT
TEXT(TIUDA,TIUJ,TIUDAD,TIUOVR,ORIGCHLD) ; Get each component
+1 NEW TIUKID,TIUDADT,TIUI,TIUD0,TIULVL,CANPRINT
SET TIUI=0
+2 SET TIUD0=$GET(^TIU(8925,+TIUDA,0))
SET TIULVL=$PIECE($GET(^TIU(8925.1,+TIUD0,0)),U,4)
+3 SET CANPRINT=$SELECT(TIULVL="DOC":$$CANDO^TIULP(TIUDA,"PRINT RECORD"),1:1)
+4 IF +TIUOVR'>0
IF (+CANPRINT'>0)
Begin DoDot:1
+5 SET TIUJ=+$GET(TIUJ)+1
+6 SET @TIUROOT@(TIUDAD,"TEXT",TIUJ,0)=$PIECE(CANPRINT,U,2)
+7 SET @TIUROOT@(TIUDAD,"TEXT",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
End DoDot:1
QUIT
+8 FOR
SET TIUI=$ORDER(^TIU(8925,+TIUDA,"TEXT",TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:1
+9 SET TIUJ=+$GET(TIUJ)+1
+10 SET @TIUROOT@(TIUDAD,"TEXT",TIUJ,0)=$GET(^TIU(8925,+TIUDA,"TEXT",TIUI,0))
End DoDot:1
+11 SET @TIUROOT@(TIUDAD,"TEXT",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
+12 ; Iterate through children, and get their text fields
+13 SET TIUKID=0
+14 FOR
SET TIUKID=$ORDER(^TIU(8925,"DAD",+TIUDA,TIUKID))
IF +TIUKID'>0
QUIT
Begin DoDot:1
+15 IF +$$ISADDNDM^TIULC1(TIUKID)
Begin DoDot:2
+16 NEW TIUADRT
+17 IF TIUROOT[")"
SET TIUADRT=$PIECE(TIUROOT,")")_","_TIUDAD_",""ZADD"")"
+18 IF '$TEST
SET TIUADRT=TIUROOT_"("_TIUDAD_",""ZADD"")"
+19 DO EXTRACT(TIUKID,TIUADRT,.TIUERR,DR,.TIUJ,1)
IF 1
End DoDot:2
+20 IF '$TEST
DO TEXT(TIUKID,.TIUJ,TIUDAD,+$GET(TIUOVR))
End DoDot:1
+21 ; Get ID kids in correct sort order; extract data for each kid:
+22 IF '$ORDER(^TIU(8925,"GDAD",TIUDA,0))
QUIT
+23 NEW TIUGDATA,TIUSORT,TIUK,TIUIDKID,TIUIDRT,CTR
+24 SET TIUGDATA=$$IDDATA^TIURECL1(TIUDA)
+25 SET TIUSORT=$PIECE(TIUGDATA,U,4)
+26 DO GETIDKID^TIURECL2(TIUDA,TIUSORT)
+27 SET TIUK=0
SET CTR=0
+28 FOR
SET TIUK=$ORDER(^TMP("TIUIDKID",$JOB,TIUDA,TIUK))
IF 'TIUK
QUIT
Begin DoDot:1
+29 SET TIUIDKID=^TMP("TIUIDKID",$JOB,TIUDA,TIUK)
+30 NEW TIUIDRT
+31 IF TIUROOT[")"
SET TIUIDRT=$PIECE(TIUROOT,")")_","_TIUDAD_",""ZZID"","_TIUK_")"
+32 IF '$TEST
SET TIUIDRT=TIUROOT_"("_TIUDAD_",""ZZID"","_TIUK_")"
+33 DO EXTRACT(TIUIDKID,TIUIDRT,.TIUERR,DR,.TIUJ,1)
+34 SET CTR=CTR+1
End DoDot:1
+35 ; How many ID kids TIUDAD has
IF CTR
SET @TIUROOT@(TIUDAD,"ZZID",0)=CTR
+36 ;I CTR,$G(ORIGCHLD) S @TIUROOT@(TIUDAD,"REASON")="Note included because interdisciplinary child meets criteria."
+37 KILL ^TMP("TIUIDKID",$JOB)
+38 QUIT
