source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPUTCN.m@ 1432

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

initial load of WorldVistAEHR
File size: 6.1 KB
RevLine 
[613]1TIUPUTCN ; SLC/JER - Uploading Consult Results ;4/18/03
2 ;;1.0;TEXT INTEGRATION UTILITIES;**4,100,120,131,113**;Jun 20, 1997
3 ; External References in TIUPUTCN:
4 ; DBIA 3472 $$CPPAT^GMRCCP
5LOOKUP ; Lookup Method for Consults document definition
6 ; Required: TIUSSN, TIUVDT,TIUCNNBR
7 N DA,DFN,TIU,TIUDAD,TIUDPRM,TIUEDIT,TIUEDT,TIULDT,TIUXCRP,TIUTYPE,TIUNEW
8 I $S('$D(TIUSSN):1,'$D(TIUVDT):1,$G(TIUSSN)?4N:1,$G(TIUSSN)']"":1,1:0) S Y=-1 G LOOKUPX
9 I TIUSSN?3N1P2N1P4N.E S TIUSSN=$TR(TIUSSN,"-/","")
10 I TIUSSN["?" S Y=-1 G LOOKUPX
11 I $G(TIUCNNBR)']"" S Y=-1 G LOOKUPX
12 S TIULOC=+$$ILOC(TIULOC)
13 I '$D(^SC(+$G(TIULOC),0)) S Y=-1 G LOOKUPX
14 S TIUINST=+$$DIVISION^TIULC1(TIULOC)
15 S TIUEDT=$$IDATE^TIULC(TIUVDT),TIULDT=$$FMADD^XLFDT(TIUEDT,1)
16 I +TIUEDT'>0 S Y=-1 Q
17 S TIUTYPE=$$WHATITLE(TIUTITLE)
18 I +TIUTYPE'>0 S Y=-1 Q
19 I $P($G(^SC(+TIULOC,0)),U,3)="W" D I 1
20 . D MAIN^TIUMOVE(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,1,"LAST",0,TIULOC)
21 E D MAIN^TIUVSIT(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,"LAST",0,TIULOC)
22 I $S($D(TIU)'>9:1,+$G(DFN)'>0:1,1:0) S Y=-1 G LOOKUPX
23 I $P(+$G(TIU("EDT")),".")'=$P($$IDATE^TIULC(TIUVDT),".") S Y=-1 G LOOKUPX
24 ; Confirm that patient from transcribed Consult Request Number matches
25 ;pt from transcribed SSN:
26 I '$$CPPAT^GMRCCP(TIUCNNBR,DFN) S Y=-1 G LOOKUPX ; TIU*1*131
27 D DOCPRM^TIULC1(TIUTYPE,.TIUDPRM)
28 S TIUTYP(1)=1_U_TIUTYPE_U_$$PNAME^TIULC1(TIUTYPE)
29 S Y=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.TIUNEW,.TIUDPRM)
30 I +Y'>0 G LOOKUPX
31 ; If record is not new, is not yet released, then delete
32 ;existing text to prepare for replacement:
33 I +$G(TIUNEW)'>0 D
34 . S TIUEDIT=$$CANEDIT(+Y)
35 . I +TIUEDIT>0,$D(^TIU(8925,+Y,"TEXT")) D DELTEXT(+Y)
36 . ; If already released, then make an addendum:
37 . I +TIUEDIT'>0 S TIUDAD=+Y,Y=$$MAKEADD
38 I +Y'>0 Q
39 ; Stuff transcribed look-up data, etc.:
40 D STUFREC(Y,+$G(TIUDAD))
41 I +$G(TIUDAD) D SENDADD^TIUALRT(+Y)
42 ; Prevent STUFREC^TIUPUTC from overwriting unneeded fields with
43 ;possibly erroneous transcribed data:
44 K TIUHDR(.01),TIUHDR(.07),TIUHDR(1301)
45LOOKUPX Q
46ILOC(LOCATION) ; Get pointer to file 44
47 N DIC,X,Y
48 S DIC=44,DIC(0)="M",X=LOCATION D ^DIC
49 Q Y
50CANEDIT(DA) ; Check if document is not released yet
51 Q $S(+$P($G(^TIU(8925,+DA,0)),U,5)<4:1,1:0) ;TIU*1*131
52MAKEADD() ; Create an addendum record
53 N DIE,DR,DA,DIC,X,Y,DLAYGO,TIUATYP,TIUFPRIV S TIUFPRIV=1
54 ; Get 8925.1 IEN for title "ADDENDUM"; DON'T require it to be consult
55 S TIUATYP=+$$WHATITLE^TIUPUTU("ADDENDUM")
56 S (DIC,DLAYGO)=8925,DIC(0)="L",X=""""_"`"_TIUATYP_""""
57 D ^DIC
58 S DA=+Y
59 I +DA>0 S DIE=DIC,DR=".04////"_$$DOCCLASS^TIULC1(TIUATYP) D ^DIE
60 K TIUHDR(.01)
61 Q +DA
62STUFREC(DA,PARENT) ; Stuff look-up header data, etc.
63 ; Stuff look-up data, data derived from look-up data, and all other
64 ;necessary, known, nontranscribed data: pt, visit, visit-derived data,
65 ;entry dt/tm, ref date, capture meth, status (unreleased).
66 ; (Remaining transcribed header data is generically stuffed later
67 ;in MAIN^TIUPUTC, along with transcribed report text.)
68 N FDA,FDARR,IENS,FLAGS,TIUMSG
69 S IENS=""""_DA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="K"
70 I +$G(PARENT)'>0 D
71 . S @FDARR@(.02)=$G(DFN),@FDARR@(.03)=$P($G(TIU("VISIT")),U)
72 . S @FDARR@(.05)=3
73 . S @FDARR@(.07)=$P($G(TIU("EDT")),U)
74 . S @FDARR@(.08)=$P($G(TIU("LDT")),U)
75 . S @FDARR@(1201)=$$NOW^TIULC
76 . S @FDARR@(1205)=$S(+$P($G(TIU("LOC")),U):$P($G(TIU("LOC")),U),1:$P($G(TIU("VLOC")),U))
77 . ;S @FDARR@(1211)=$P($G(TIU("VLOC")),U)
78 . S @FDARR@(1404)=$P($G(TIU("SVC")),U)
79 I +$G(PARENT)>0 D
80 . S @FDARR@(.02)=+$P($G(^TIU(8925,+PARENT,0)),U,2)
81 . S @FDARR@(.03)=+$P($G(^TIU(8925,+PARENT,0)),U,3),@FDARR@(.05)=3
82 . S @FDARR@(.06)=PARENT
83 . S @FDARR@(.07)=$P($G(^TIU(8925,+PARENT,0)),U,7)
84 . S @FDARR@(.08)=$P($G(^TIU(8925,+PARENT,0)),U,8)
85 . S @FDARR@(1205)=$P($G(^TIU(8925,+PARENT,12)),U,5)
86 . S @FDARR@(1404)=$P($G(^TIU(8925,+PARENT,14)),U,4)
87 . S @FDARR@(1201)=$$NOW^TIULC
88 S @FDARR@(1205)=$P($G(TIU("LOC")),U)
89 S @FDARR@(1212)=$P($G(TIU("INST")),U)
90 S @FDARR@(1301)=$S($G(TIUDDT)]"":$$IDATE^TIULC($G(TIUDDT)),1:"")
91 I @FDARR@(1301)'>0 S @FDARR@(1301)=$G(@FDARR@(.07))
92 S @FDARR@(1303)="U"
93 D FILE^DIE(FLAGS,"FDA","TIUMSG") ; File record
94 Q
95DELTEXT(DA) ; Delete existing text in preparation for replacement
96 N DIE,DR,X,Y
97 S DIE=8925,DR="2///@" D ^DIE
98 Q
99WHATYPE(X) ; Identify document type
100 ; Receives: X=Document Definition Name
101 ; Returns: Y=Document Definition IFN
102 N DIC,Y,TIUFPRIV S TIUFPRIV=1
103 S DIC=8925.1,DIC(0)="M"
104 S DIC("S")="I +$O(^TIU(8925.1,+Y,""HEAD"",0))!+$O(^TIU(8295.1,+Y,""ITEM"",0))"
105 D ^DIC K DIC("S")
106WHATYPX Q Y
107WHATITLE(X) ; Identify document title
108 ; Receives: X=Document Definition Name
109 ; Returns: Y=Document Definition IFN
110 N DIC,Y,TIUFPRIV,SCREEN,TIUCLASS S TIUFPRIV=1
111 S DIC=8925.1,DIC(0)="M",TIUCLASS=+$$CLASS^TIUCNSLT
112 S SCREEN="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"",+$$ISA^TIULX(+Y,"_TIUCLASS_"),+$$CANPICK^TIULP(+Y)"
113 S DIC("S")=SCREEN
114 D ^DIC K DIC("S")
115WHATITX Q Y
116FOLLOWUP(TIUDA) ; Post-filing code for CONSULTS
117 N FDA,FDARR,IENS,FLAGS,TIUMSG,TIU,DFN
118 S IENS=""""_TIUDA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="K"
119 S @FDARR@(1204)=$$WHOSIGNS^TIULC1(TIUDA)
120 I +$P($G(^TIU(8925,TIUDA,12)),U,9),'+$P($G(^(12)),U,8) D
121 . S @FDARR@(1208)=$$WHOCOSIG^TIULC1(TIUDA)
122 D FILE^DIE(FLAGS,"FDA","TIUMSG")
123 I +$P($G(^TIU(8925,+TIUDA,12)),U,8),(+$P($G(^TIU(8925,+TIUDA,12)),U,4)'=+$P($G(^(12)),U,8)) D
124 . S @FDARR@(1506)=1 D FILE^DIE(FLAGS,"FDA","TIUMSG")
125 D RELEASE^TIUT(TIUDA,1)
126 D AUDIT^TIUEDI1(TIUDA,0,$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")"))
127 I +$P($G(^TIU(8925,+TIUDA,14)),U,5) D
128 . N TIUCDA,DA S TIUCDA=+$P($G(^TIU(8925,+TIUDA,14)),U,5)
129 . W !,$$PNAME^TIULC1(+$G(^TIU(8925,+TIUDA,0)))," #: ",TIUDA
130 . W " now Linked to Consult Request #: ",TIUCDA,".",!
131 . ; Post result in CT Pkg
132 . D GET^GMRCTIU(TIUCDA,TIUDA,"INCOMPLETE RPT")
133 I '$D(TIU("VSTR")) D
134 . N TIUD0,TIUD12,TIUVLOC,TIUHLOC,TIUEDT,TIULDT
135 . S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^(12))
136 . S DFN=+$P(TIUD0,U,2),TIUEDT=+$P(TIUD0,U,7)
137 . S TIULDT=$$FMADD^XLFDT(TIUEDT,1),TIUHLOC=+$P(TIUD12,U,5)
138 . S TIUVLOC=$S(+$P(TIUD12,U,11):+$P(TIUD12,U,11),1:+TIUHLOC)
139 . I $S(+DFN'>0:1,+TIUEDT'>0:1,+TIULDT'>0:1,+TIUVLOC'>0:1,1:0) Q
140 . D MAIN^TIUVSIT(.TIU,DFN,"",TIUEDT,TIULDT,"LAST",0,+TIUVLOC)
141 Q:'$D(TIU("VSTR"))
142 D QUE^TIUPXAP1 ; Get/file VISIT
143 Q
Note: See TracBrowser for help on using the repository browser.