source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULQ.m@ 1000

Last change on this file since 1000 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1TIULQ ; SLC/JER - Record Extract Using FM Retriever ; 3/1/06 3:46pm
2 ;;1.0;TEXT INTEGRATION UTILITIES;**19,100,157,211**;Jun 20, 1997;Build 26
3EXTRACT(TIUDA,TIUROOT,TIUERR,DR,TIULINE,TIUTEXT,FORMAT,OVRRIDE,ORIGCHLD) ; Gets record & addenda and ID kids
4 ; Do we need a new DBIA here? MARGY
5 N DA,DIC,DIQ,TIULQ,X,Y
6 S TIUROOT=$G(TIUROOT,"^TMP(""TIULQ"",$J)")
7 S DA=TIUDA,DIC=8925,DIQ="TIULQ",DIQ(0)=$G(FORMAT,"IE")
8 I $G(DR)']"" S DR=".01:.1;1201:1701;89261"
9 D EN^DIQ1
10 I '$D(TIULQ) S TIUERR="1^ Record Extract Failed"
11 M @TIUROOT@(TIUDA)=TIULQ(8925,TIUDA)
12 D XTRASIGN(DA,+$G(TIULINE))
13 D PROBLEMS(DA,+$G(TIULINE))
14 I +$G(TIUTEXT) D TEXT(TIUDA,+$G(TIULINE),TIUDA,+$G(OVRRIDE),+$G(ORIGCHLD))
15 Q
16XTRASIGN(TIUDA,TIUJ) ; Get Extra Signers
17 N TIUI,TIUXTRA,TIUC,DR,DIC,DIQ S TIUI=0
18 F S TIUI=$O(^TIU(8925.7,"B",+TIUDA,TIUI)) Q:+TIUI'>0 D
19 . N TIUDT,TIUSGN,TIUSNM,TIUSTTL,TIUEIEN,TIUENAME
20 . S DA=TIUI,DR=".03:.07",DIC="^TIU(8925.7,",DIQ="TIUXTRA",DIQ(0)="IE"
21 . D EN^DIQ1 Q:$D(TIUXTRA)'>9
22 . S TIUC=+$G(TIUC)+1
23 . S TIUEIEN=$G(TIUXTRA(8925.7,DA,.03,"I"))
24 . S TIUENAME=$G(TIUXTRA(8925.7,DA,.03,"E"))
25 . S TIUDT=$G(TIUXTRA(8925.7,DA,.04,"I"))
26 . S TIUSGN=$G(TIUXTRA(8925.7,DA,.05,"I"))
27 . S TIUSNM=$G(TIUXTRA(8925.7,DA,.06,"E"))
28 . S TIUSTTL=$G(TIUXTRA(8925.7,DA,.07,"E"))
29 . S @TIUROOT@(TIUDA,"EXTRASGNR",(TIUJ+TIUC),"EXPIEN")=TIUEIEN
30 . S @TIUROOT@(TIUDA,"EXTRASGNR",(TIUJ+TIUC),"EXPNAME")=TIUENAME
31 . S @TIUROOT@(TIUDA,"EXTRASGNR",(TIUJ+TIUC),"DATE")=TIUDT
32 . S @TIUROOT@(TIUDA,"EXTRASGNR",(TIUJ+TIUC),"EXTRA")=TIUSGN
33 . S @TIUROOT@(TIUDA,"EXTRASGNR",(TIUJ+TIUC),"NAME")=TIUSNM
34 . S @TIUROOT@(TIUDA,"EXTRASGNR",(TIUJ+TIUC),"TITLE")=TIUSTTL
35 Q
36PROBLEMS(TIUDA,TIUJ) ; Get associated problems
37 N TIUI,TIUP,TIUPROB,TIUC,TIUX,DR,DIC,DIQ S TIUI=0
38 F S TIUI=$O(^TIU(8925.9,"B",+TIUDA,TIUI)) Q:+TIUI'>0 D
39 . S DA=TIUI,DR=".02;.05",DIC="^TIU(8925.9,",DIQ="TIUPROB"
40 . D EN^DIQ1 Q:$D(TIUPROB)'>9
41 . S TIUC=+$G(TIUC)+1
42 . S TIUP=$$MIXED^TIULS($G(TIUPROB(8925.9,TIUI,.05)))
43 . S TIUX=$$SETSTR^VALM1($J(TIUC,2)_".",$G(TIUX),1,3)
44 . S TIUX=$$SETSTR^VALM1(TIUP,$G(TIUX),5,35)
45 . S TIUP=$G(TIUPROB(8925.9,TIUI,.02))
46 . S TIUX=$$SETSTR^VALM1(TIUP,$G(TIUX),40,6)
47 . S @TIUROOT@(TIUDA,"PROBLEM",(TIUJ+TIUC),0)=TIUX
48 Q
49TEXT(TIUDA,TIUJ,TIUDAD,TIUOVR,ORIGCHLD) ; Get each component
50 N TIUKID,TIUDADT,TIUI,TIUD0,TIULVL,CANPRINT S TIUI=0
51 S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIULVL=$P($G(^TIU(8925.1,+TIUD0,0)),U,4)
52 S CANPRINT=$S(TIULVL="DOC":$$CANDO^TIULP(TIUDA,"PRINT RECORD"),1:1)
53 I +TIUOVR'>0,(+CANPRINT'>0) D Q
54 . S TIUJ=+$G(TIUJ)+1
55 . S @TIUROOT@(TIUDAD,"TEXT",TIUJ,0)=$P(CANPRINT,U,2)
56 . S @TIUROOT@(TIUDAD,"TEXT",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
57 F S TIUI=$O(^TIU(8925,+TIUDA,"TEXT",TIUI)) Q:+TIUI'>0 D
58 . S TIUJ=+$G(TIUJ)+1
59 . S @TIUROOT@(TIUDAD,"TEXT",TIUJ,0)=$G(^TIU(8925,+TIUDA,"TEXT",TIUI,0))
60 S @TIUROOT@(TIUDAD,"TEXT",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
61 ; Iterate through children, and get their text fields
62 S TIUKID=0
63 F S TIUKID=$O(^TIU(8925,"DAD",+TIUDA,TIUKID)) Q:+TIUKID'>0 D
64 . I +$$ISADDNDM^TIULC1(TIUKID) D
65 . . N TIUADRT
66 . . I TIUROOT[")" S TIUADRT=$P(TIUROOT,")")_","_TIUDAD_",""ZADD"")"
67 . . E S TIUADRT=TIUROOT_"("_TIUDAD_",""ZADD"")"
68 . . D EXTRACT(TIUKID,TIUADRT,.TIUERR,DR,.TIUJ,1) I 1
69 . E D TEXT(TIUKID,.TIUJ,TIUDAD,+$G(TIUOVR))
70 ; Get ID kids in correct sort order; extract data for each kid:
71 Q:'$O(^TIU(8925,"GDAD",TIUDA,0))
72 N TIUGDATA,TIUSORT,TIUK,TIUIDKID,TIUIDRT,CTR
73 S TIUGDATA=$$IDDATA^TIURECL1(TIUDA)
74 S TIUSORT=$P(TIUGDATA,U,4)
75 D GETIDKID^TIURECL2(TIUDA,TIUSORT)
76 S TIUK=0,CTR=0
77 F S TIUK=$O(^TMP("TIUIDKID",$J,TIUDA,TIUK)) Q:'TIUK D
78 . S TIUIDKID=^TMP("TIUIDKID",$J,TIUDA,TIUK)
79 . N TIUIDRT
80 . I TIUROOT[")" S TIUIDRT=$P(TIUROOT,")")_","_TIUDAD_",""ZZID"","_TIUK_")"
81 . E S TIUIDRT=TIUROOT_"("_TIUDAD_",""ZZID"","_TIUK_")"
82 . D EXTRACT(TIUIDKID,TIUIDRT,.TIUERR,DR,.TIUJ,1)
83 . S CTR=CTR+1
84 I CTR S @TIUROOT@(TIUDAD,"ZZID",0)=CTR ; How many ID kids TIUDAD has
85 ;I CTR,$G(ORIGCHLD) S @TIUROOT@(TIUDAD,"REASON")="Note included because interdisciplinary child meets criteria."
86 K ^TMP("TIUIDKID",$J)
87 Q
Note: See TracBrowser for help on using the repository browser.