source: FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPUTPF.m@ 1015

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

initial load of FOIAVistA 6/30/08 version
File size: 6.4 KB
Line 
1TIUPUTPF ; SLC/JER - PRF Look-up Method - ;10/9/05
2 ;;1.0;TEXT INTEGRATION UTILITIES;**184**;Jun 20, 1997
3 ; COPIED FROM TIUPUTPN AND THEN EDITED
4LOOKUP ; Look-up code used by router/filer
5 ; Required: TIUSSN, TIUVDT
6 ; -- Selected flag action is set in LOOKUP & in GETCHECK^TIUPFFIX;
7 ; Action is used in post-file code to link note.
8 ; Kill it before setting it:
9 K ^TMP("TIUPRFUP",$J)
10 N DA,DFN,TIU,TIUDAD,TIUEDIT,TIUEDT,TIULDT,TIUXCRP,TIUTYPE
11 N TIUNEW,TIUEXIST,TIUDPRM,TIUASACT
12 S TIUEXIST=1
13 I $S('$D(TIUSSN):1,'$D(TIUVDT):1,$G(TIUSSN)?4N:1,$G(TIUSSN)']"":1,1:0) S Y=-1 G LOOKUPX
14 I TIUSSN?3N1P2N1P4N.E S TIUSSN=$TR(TIUSSN,"-/","")
15 I TIUSSN["?" S Y=-1 G LOOKUPX
16 S TIULOC=+$$ILOC(TIULOC)
17 I '$D(^SC(+$G(TIULOC),0)) S Y=-1 G LOOKUPX
18 S TIUINST=+$$DIVISION^TIULC1(TIULOC)
19 S TIUEDT=$$IDATE^TIULC(TIUVDT),TIULDT=$$FMADD^XLFDT(TIUEDT,1)
20 I +TIUEDT'>0 S Y=-1 Q
21 S TIUTYPE=$$WHATITLE(TIUTITLE)
22 I +TIUTYPE'>0 S Y=-1 Q
23 ; -- Abort upload if title is not a PRF title:
24 I '$$ISPFTTL^TIUPRFL(+TIUTYPE) S Y=-1 Q
25 D DOCPRM^TIULC1(+TIUTYPE,.TIUDPRM)
26 I $P($G(^SC(+TIULOC,0)),U,3)="W" D I 1
27 . D MAIN^TIUMOVE(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,1,"LAST",0,TIULOC)
28 E D MAIN^TIUVSIT(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,"LAST",0,TIULOC)
29 I $S($D(TIU)'>9:1,+$G(DFN)'>0:1,1:0) S Y=-1 G LOOKUPX
30 I $P(+$G(TIU("EDT")),".")'=$P($$IDATE^TIULC(TIUVDT),".") S Y=-1 G LOOKUPX
31 I '+$$EXIST^TIUEDI3(DFN,+TIUTYPE,TIU("VSTR"),1,DUZ) S TIUEXIST=0 D
32 . ; -- If refiling after filing error, get flag assignment^action
33 . ; from user:
34 . I $G(PRFILERR) S TIUASACT=$$SELECT^TIUPRF1(+TIUTYPE,DFN)
35 . ; -- If not, try for one available action:
36 . I '$G(PRFILERR) K ^TMP("TIUPRF",$J) S TIUASACT=$$ONEACT(DFN,+TIUTYPE) K ^TMP("TIUPRF",$J)
37 . I TIUASACT S ^TMP("TIUPRFUP",$J)=TIUASACT
38 I 'TIUEXIST,'$G(^TMP("TIUPRFUP",$J)) S Y=-1 G LOOKUPX
39 S TIUTYP(1)=1_U_TIUTYPE_U_$$PNAME^TIULC1(TIUTYPE)
40 S Y=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.TIUNEW,.TIUDPRM)
41 I +Y'>0 G LOOKUPX
42 ; If record is not new, has text and can be edited, then replace
43 ; existing text
44 I +$G(TIUNEW)'>0 D
45 . S TIUEDIT=$$CANEDIT(+Y)
46 . I +TIUEDIT>0,$D(^TIU(8925,+Y,"TEXT")) D DELTEXT(+Y)
47 . I +TIUEDIT'>0 S TIUDAD=+Y,Y=$$MAKEADD
48 I +Y'>0 Q
49 D STUFREC(Y,+$G(TIUDAD))
50 I +$G(TIUDAD) D SENDADD^TIUALRT(+Y)
51 K TIUHDR(.01),TIUHDR(.07),TIUHDR(1301)
52LOOKUPX Q
53 ;
54ONEACT(DFN,TIUTYPE) ; If there is exactly one Assigment History Action
55 ; available for pat DFN & Title TIUTYPE, return ASSGNIEN^ACTIEN;
56 ; else return 0
57 ;Count only unlinked, linkable actions
58 ;An action is LINKABLE if it is not ENTERED IN ERROR (EIE) and
59 ; is not taken prior to an EIE action.
60 N TIUDG,TIUASSGN,ONEIEN,RESULT,ARRAYNM
61 S RESULT=0,ARRAYNM="^TMP(""TIUPRFH"",$J)"
62 S TIUDG=$$GETHTIU^DGPFAPI1(DFN,+TIUTYPE,ARRAYNM)
63 I 'TIUDG G ONEACTX
64 S TIUASSGN=+$G(@ARRAYNM@("ASSIGNIEN"))
65 I $$AVAILACT^TIUPRFL(ARRAYNM,,,.ONEIEN)=1 S RESULT=TIUASSGN_U_ONEIEN
66ONEACTX ;
67 K ^TMP("TIUPRFH",$J)
68 Q RESULT
69 ;
70ILOC(LOCATION) ; Get pointer to file 44
71 N DIC,X,Y
72 S DIC=44,DIC(0)="M",X=LOCATION D ^DIC
73 Q Y
74CANEDIT(DA) ; Check whether or not document is released
75 Q $S(+$P($G(^TIU(8925,+DA,0)),U,5)<4:1,1:0)
76MAKEADD() ; Create an addendum record
77 N DIE,DR,DA,DIC,X,Y,DLAYGO,TIUATYP,TIUFPRIV S TIUFPRIV=1
78 S TIUATYP=+$$WHATITLE("ADDENDUM")
79 S (DIC,DLAYGO)=8925,DIC(0)="L",X=""""_"`"_TIUATYP_""""
80 D ^DIC
81 S DA=+Y
82 I +DA>0 S DIE=DIC,DR=".04////"_$$DOCCLASS^TIULC1(TIUATYP) D ^DIE
83 K TIUHDR(.01)
84 Q +DA
85STUFREC(DA,PARENT) ; Stuff fixed field data
86 N FDA,FDARR,IENS,FLAGS,TIUMSG
87 S IENS=""""_DA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="K"
88 I +$G(PARENT)'>0 D
89 . S @FDARR@(.02)=$G(DFN),@FDARR@(.03)=$P($G(TIU("VISIT")),U)
90 . S @FDARR@(.05)=3
91 . S @FDARR@(.07)=$P($G(TIU("EDT")),U)
92 . S @FDARR@(.08)=$P($G(TIU("LDT")),U)
93 . S @FDARR@(1201)=$$NOW^TIULC
94 . S @FDARR@(1205)=$S(+$P($G(TIU("LOC")),U):$P($G(TIU("LOC")),U),1:$P($G(TIU("VLOC")),U))
95 . ;S @FDARR@(1211)=$P($G(TIU("VLOC")),U)
96 . S @FDARR@(1404)=$P($G(TIU("SVC")),U)
97 I +$G(PARENT)>0 D
98 . S @FDARR@(.02)=+$P($G(^TIU(8925,+PARENT,0)),U,2)
99 . S @FDARR@(.03)=+$P($G(^TIU(8925,+PARENT,0)),U,3),@FDARR@(.05)=3
100 . S @FDARR@(.06)=PARENT
101 . S @FDARR@(.07)=$P($G(^TIU(8925,+PARENT,0)),U,7)
102 . S @FDARR@(.08)=$P($G(^TIU(8925,+PARENT,0)),U,8)
103 . S @FDARR@(1205)=$P($G(^TIU(8925,+PARENT,12)),U,5)
104 . S @FDARR@(1404)=$P($G(^TIU(8925,+PARENT,14)),U,4)
105 . S @FDARR@(1201)=$$NOW^TIULC
106 S @FDARR@(1205)=$P($G(TIU("LOC")),U)
107 S @FDARR@(1212)=$P($G(TIU("INST")),U)
108 S @FDARR@(1301)=$S($G(TIUDDT)]"":$$IDATE^TIULC($G(TIUDDT)),1:"")
109 I $S(@FDARR@(1301)'>0:1,$P(@FDARR@(1301),".",2)']"":1,1:0) D
110 . S @FDARR@(1301)=$S($P($G(TIU("VSTR")),";",3)="H":$$NOW^XLFDT,1:$G(@FDARR@(.07)))
111 S @FDARR@(1303)="U"
112 D FILE^DIE(FLAGS,"FDA","TIUMSG") ; File record
113 Q
114DELTEXT(DA) ; Delete existing text in preparation for replacement
115 N DIE,DR,X,Y
116 S DIE=8925,DR="2///@" D ^DIE
117 Q
118WHATYPE(X) ; Identify document type
119 ; Receives: X=Document Definition Name
120 ; Returns: Y=Document Definition IFN
121 N DIC,Y,TIUFPRIV S TIUFPRIV=1
122 S DIC=8925.1,DIC(0)="M"
123 S DIC("S")="I $D(^TIU(8925.1,+Y,""HEAD""))!$D(^TIU(8295.1,+Y,""ITEM""))"
124 D ^DIC K DIC("S")
125WHATYPX Q Y
126WHATITLE(X) ; Identify document title
127 ; Receives: X=Document Definition Name
128 ; Returns: Y=Document Definition IFN
129 N DIC,Y,TIUFPRIV S TIUFPRIV=1
130 S DIC=8925.1,DIC(0)="M"
131 S DIC("S")="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"""
132 D ^DIC K DIC("S")
133WHATITX Q Y
134FOLLOWUP(TIUDA) ; Post-filing code for PRF
135 N FDA,FDARR,IENS,FLAGS,TIUMSG,TIU,DFN,TIUTEMP
136 S IENS=""""_TIUDA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="K"
137 S @FDARR@(1204)=$$WHOSIGNS^TIULC1(TIUDA)
138 I +$P($G(^TIU(8925,TIUDA,12)),U,9),'+$P($G(^(12)),U,8) D
139 . S @FDARR@(1208)=$$WHOCOSIG^TIULC1(TIUDA)
140 D FILE^DIE(FLAGS,"FDA","TIUMSG")
141 I +$P($G(^TIU(8925,+TIUDA,12)),U,8),(+$P($G(^TIU(8925,+TIUDA,12)),U,4)'=+$P($G(^(12)),U,8)) D
142 . S @FDARR@(1506)=1 D FILE^DIE(FLAGS,"FDA","TIUMSG")
143 D RELEASE^TIUT(TIUDA,1)
144 D AUDIT^TIUEDI1(TIUDA,0,$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")"))
145 I $G(^TMP("TIUPRFUP",$J)) D
146 . N TIUDFN S TIUDFN=$P($G(^TIU(8925,TIUDA,0)),U,2)
147 . S TIUTEMP=$$LINK^TIUPRF1(TIUDA,$P($G(^TMP("TIUPRFUP",$J)),U),$P($G(^TMP("TIUPRFUP",$J)),U,2),TIUDFN)
148 . K ^TMP("TIUPRFUP",$J)
149 I '$D(TIU("VSTR")) D
150 . N TIUD0,TIUD12,TIUVLOC,TIUHLOC,TIUEDT,TIULDT
151 . S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^(12))
152 . S DFN=+$P(TIUD0,U,2),TIUEDT=+$P(TIUD0,U,7)
153 . S TIULDT=$$FMADD^XLFDT(TIUEDT,1),TIUHLOC=+$P(TIUD12,U,5)
154 . S TIUVLOC=$S(+$P(TIUD12,U,11):+$P(TIUD12,U,11),1:+TIUHLOC)
155 . I $S(+DFN'>0:1,+TIUEDT'>0:1,+TIULDT'>0:1,+TIUVLOC'>0:1,1:0) Q
156 . D MAIN^TIUVSIT(.TIU,DFN,"",TIUEDT,TIULDT,"LAST",0,+TIUVLOC)
157 Q:'$D(TIU("VSTR"))
158 D ENQ^TIUPXAP1 ; Get/file VISIT
159 Q
Note: See TracBrowser for help on using the repository browser.