- 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
