source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPUTPN.m@ 1361

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

initial load of WorldVistAEHR
File size: 5.0 KB
RevLine 
[613]1TIUPUTPN ; SLC/JER - PN Look-up Method ;4/18/03
2 ;;1.0;TEXT INTEGRATION UTILITIES;**3,21,100,131,113**;Jun 20, 1997
3LOOKUP ; Look-up code used by router/filer
4 ; Required: TIUSSN, TIUVDT
5 N DA,DFN,TIU,TIUDAD,TIUEDIT,TIUEDT,TIULDT,TIUXCRP,TIUTYPE,TIUNEW
6 N TIUDPRM
7 I $S('$D(TIUSSN):1,'$D(TIUVDT):1,$G(TIUSSN)?4N:1,$G(TIUSSN)']"":1,1:0) S Y=-1 G LOOKUPX
8 I TIUSSN?3N1P2N1P4N.E S TIUSSN=$TR(TIUSSN,"-/","")
9 I TIUSSN["?" S Y=-1 G LOOKUPX
10 S TIULOC=+$$ILOC(TIULOC)
11 I '$D(^SC(+$G(TIULOC),0)) S Y=-1 G LOOKUPX
12 S TIUINST=+$$DIVISION^TIULC1(TIULOC)
13 S TIUEDT=$$IDATE^TIULC(TIUVDT),TIULDT=$$FMADD^XLFDT(TIUEDT,1)
14 I +TIUEDT'>0 S Y=-1 Q
15 S TIUTYPE=$$WHATITLE(TIUTITLE)
16 I +TIUTYPE'>0 S Y=-1 Q
17 ; -- Abort upload if title is consult title:
18 I $$ISA^TIULX(+TIUTYPE,+$$CLASS^TIUCNSLT) S Y=-1 Q ; TIU*1*131
19 D DOCPRM^TIULC1(+TIUTYPE,.TIUDPRM)
20 I $P($G(^SC(+TIULOC,0)),U,3)="W" D I 1
21 . D MAIN^TIUMOVE(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,1,"LAST",0,TIULOC)
22 E D MAIN^TIUVSIT(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,"LAST",0,TIULOC)
23 I $S($D(TIU)'>9:1,+$G(DFN)'>0:1,1:0) S Y=-1 G LOOKUPX
24 I $P(+$G(TIU("EDT")),".")'=$P($$IDATE^TIULC(TIUVDT),".") S Y=-1 G LOOKUPX
25 S TIUTYP(1)=1_U_TIUTYPE_U_$$PNAME^TIULC1(TIUTYPE)
26 ;S Y=$$GETREC^TIUEDI1(DFN,.TIU,1,.TIUNEW,.TIUDPRM)
27 S Y=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.TIUNEW,.TIUDPRM)
28 I +Y'>0 G LOOKUPX
29 ; If record is not new, has text and can be edited, then replace
30 ; existing text
31 I +$G(TIUNEW)'>0 D
32 . S TIUEDIT=$$CANEDIT(+Y)
33 . I +TIUEDIT>0,$D(^TIU(8925,+Y,"TEXT")) D DELTEXT(+Y)
34 . I +TIUEDIT'>0 S TIUDAD=+Y,Y=$$MAKEADD
35 I +Y'>0 Q
36 D STUFREC(Y,+$G(TIUDAD))
37 I +$G(TIUDAD) D SENDADD^TIUALRT(+Y)
38 K TIUHDR(.01),TIUHDR(.07),TIUHDR(1301)
39LOOKUPX Q
40ILOC(LOCATION) ; Get pointer to file 44
41 N DIC,X,Y
42 S DIC=44,DIC(0)="M",X=LOCATION D ^DIC
43 Q Y
44CANEDIT(DA) ; Check whether or not document is released
45 Q $S(+$P($G(^TIU(8925,+DA,0)),U,5)<4:1,1:0)
46MAKEADD() ; Create an addendum record
47 N DIE,DR,DA,DIC,X,Y,DLAYGO,TIUATYP,TIUFPRIV S TIUFPRIV=1
48 S TIUATYP=+$$WHATITLE("ADDENDUM")
49 S (DIC,DLAYGO)=8925,DIC(0)="L",X=""""_"`"_TIUATYP_""""
50 D ^DIC
51 S DA=+Y
52 I +DA>0 S DIE=DIC,DR=".04////"_$$DOCCLASS^TIULC1(TIUATYP) D ^DIE
53 K TIUHDR(.01)
54 Q +DA
55STUFREC(DA,PARENT) ; Stuff fixed field data
56 N FDA,FDARR,IENS,FLAGS,TIUMSG
57 S IENS=""""_DA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="K"
58 I +$G(PARENT)'>0 D
59 . S @FDARR@(.02)=$G(DFN),@FDARR@(.03)=$P($G(TIU("VISIT")),U)
60 . S @FDARR@(.05)=3
61 . S @FDARR@(.07)=$P($G(TIU("EDT")),U)
62 . S @FDARR@(.08)=$P($G(TIU("LDT")),U)
63 . S @FDARR@(1201)=$$NOW^TIULC
64 . S @FDARR@(1205)=$S(+$P($G(TIU("LOC")),U):$P($G(TIU("LOC")),U),1:$P($G(TIU("VLOC")),U))
65 . ;S @FDARR@(1211)=$P($G(TIU("VLOC")),U)
66 . S @FDARR@(1404)=$P($G(TIU("SVC")),U)
67 I +$G(PARENT)>0 D
68 . S @FDARR@(.02)=+$P($G(^TIU(8925,+PARENT,0)),U,2)
69 . S @FDARR@(.03)=+$P($G(^TIU(8925,+PARENT,0)),U,3),@FDARR@(.05)=3
70 . S @FDARR@(.06)=PARENT
71 . S @FDARR@(.07)=$P($G(^TIU(8925,+PARENT,0)),U,7)
72 . S @FDARR@(.08)=$P($G(^TIU(8925,+PARENT,0)),U,8)
73 . S @FDARR@(1205)=$P($G(^TIU(8925,+PARENT,12)),U,5)
74 . S @FDARR@(1404)=$P($G(^TIU(8925,+PARENT,14)),U,4)
75 . S @FDARR@(1201)=$$NOW^TIULC
76 S @FDARR@(1205)=$P($G(TIU("LOC")),U)
77 S @FDARR@(1212)=$P($G(TIU("INST")),U)
78 S @FDARR@(1301)=$S($G(TIUDDT)]"":$$IDATE^TIULC($G(TIUDDT)),1:"")
79 I $S(@FDARR@(1301)'>0:1,$P(@FDARR@(1301),".",2)']"":1,1:0) D
80 . S @FDARR@(1301)=$S($P($G(TIU("VSTR")),";",3)="H":$$NOW^XLFDT,1:$G(@FDARR@(.07)))
81 S @FDARR@(1303)="U"
82 D FILE^DIE(FLAGS,"FDA","TIUMSG") ; File record
83 Q
84DELTEXT(DA) ; Delete existing text in preparation for replacement
85 N DIE,DR,X,Y
86 S DIE=8925,DR="2///@" D ^DIE
87 Q
88WHATYPE(X) ; Identify document type
89 ; Receives: X=Document Definition Name
90 ; Returns: Y=Document Definition IFN
91 N DIC,Y,TIUFPRIV S TIUFPRIV=1
92 S DIC=8925.1,DIC(0)="M"
93 S DIC("S")="I $D(^TIU(8925.1,+Y,""HEAD""))!$D(^TIU(8295.1,+Y,""ITEM""))"
94 D ^DIC K DIC("S")
95WHATYPX Q Y
96WHATITLE(X) ; Identify document title
97 ; Receives: X=Document Definition Name
98 ; Returns: Y=Document Definition IFN
99 N DIC,Y,TIUFPRIV S TIUFPRIV=1
100 S DIC=8925.1,DIC(0)="M"
101 S DIC("S")="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"""
102 D ^DIC K DIC("S")
103WHATITX Q Y
104FOLLOWUP(TIUDA) ; Post-filing code for PROGRESS NOTES
105 N FDA,FDARR,IENS,FLAGS,TIUMSG,TIU,DFN
106 S IENS=""""_TIUDA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="K"
107 S @FDARR@(1204)=$$WHOSIGNS^TIULC1(TIUDA)
108 I +$P($G(^TIU(8925,TIUDA,12)),U,9),'+$P($G(^(12)),U,8) D
109 . S @FDARR@(1208)=$$WHOCOSIG^TIULC1(TIUDA)
110 D FILE^DIE(FLAGS,"FDA","TIUMSG")
111 I +$P($G(^TIU(8925,+TIUDA,12)),U,8),(+$P($G(^TIU(8925,+TIUDA,12)),U,4)'=+$P($G(^(12)),U,8)) D
112 . S @FDARR@(1506)=1 D FILE^DIE(FLAGS,"FDA","TIUMSG")
113 D RELEASE^TIUT(TIUDA,1)
114 D AUDIT^TIUEDI1(TIUDA,0,$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")"))
115 I '$D(TIU("VSTR")) D
116 . N TIUD0,TIUD12,TIUVLOC,TIUHLOC,TIUEDT,TIULDT
117 . S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^(12))
118 . S DFN=+$P(TIUD0,U,2),TIUEDT=+$P(TIUD0,U,7)
119 . S TIULDT=$$FMADD^XLFDT(TIUEDT,1),TIUHLOC=+$P(TIUD12,U,5)
120 . S TIUVLOC=$S(+$P(TIUD12,U,11):+$P(TIUD12,U,11),1:+TIUHLOC)
121 . I $S(+DFN'>0:1,+TIUEDT'>0:1,+TIULDT'>0:1,+TIUVLOC'>0:1,1:0) Q
122 . D MAIN^TIUVSIT(.TIU,DFN,"",TIUEDT,TIULDT,"LAST",0,+TIUVLOC)
123 Q:'$D(TIU("VSTR"))
124 D ENQ^TIUPXAP1 ; Get/file VISIT
125 Q
Note: See TracBrowser for help on using the repository browser.