| [623] | 1 | LRWLST1 ;DALOI/CJS/RWF/FHS - ACCESSION SETUP ; July 19, 2006
|
|---|
| 2 | ;;5.2;LAB SERVICE;**48,65,121,153,261,286,331**;Sep 27, 1994;Build 7
|
|---|
| 3 | ;
|
|---|
| 4 | ; Reference to ^DIC(42 supported by IA #10039
|
|---|
| 5 | ; Reference to ^SC( supported by IA #10040
|
|---|
| 6 | ;
|
|---|
| 7 | S LRWLC=0
|
|---|
| 8 | F S LRWLC=$O(LRTSTS(LRWLC)) Q:LRWLC<1 S LRAD=DT D SPLIT
|
|---|
| 9 | ;
|
|---|
| 10 | ; If LEDI and comments came with order then copy to order in #69
|
|---|
| 11 | I $G(LRORDRR)="R",$G(LR696),$D(^LRO(69.6,LR696,99)) D
|
|---|
| 12 | . N LRDIE
|
|---|
| 13 | . D WP^DIE(69.01,LRSN_","_LRODT_",",16,"A","^LRO(69.6,LR696,99)","LRDIE(16)")
|
|---|
| 14 | ;
|
|---|
| 15 | K DIC,DLAYGO,DR,DA,DIE,LRIXX
|
|---|
| 16 | Q:$G(LRORDR)="P"
|
|---|
| 17 | K LRNM,LRTSTS
|
|---|
| 18 | K ^TMP("LR",$J,"TMP")
|
|---|
| 19 | Q
|
|---|
| 20 | ;
|
|---|
| 21 | SPLIT ;
|
|---|
| 22 | N LRAA,LRX
|
|---|
| 23 | ; Setup regular accessions (LRUNQ=0)
|
|---|
| 24 | S LRUNQ=0,LREND=0
|
|---|
| 25 | I $D(LRTSTS(LRWLC,0)) D
|
|---|
| 26 | . D GTWLN
|
|---|
| 27 | . I LREND Q
|
|---|
| 28 | . S LRAA=0
|
|---|
| 29 | . F S LRAA=$O(LRTSTS(LRWLC,0,LRAA)) Q:LRAA<1 D
|
|---|
| 30 | . . S LRSS=LRTSTS(LRWLC,0,LRAA)
|
|---|
| 31 | . . D STWLN,ST2,^LRWLST11,EN^LA7ADL(LRUID)
|
|---|
| 32 | . D SICA^LRWLST11
|
|---|
| 33 | ;
|
|---|
| 34 | ; Setup accessions requiring 'unique' accession numbers (LRUNQ=1)
|
|---|
| 35 | S LRUNQ=1,LRAA=0
|
|---|
| 36 | F S LRAA=$O(LRTSTS(LRWLC,1,LRAA)) Q:LRAA<1 D
|
|---|
| 37 | . S LRSS=LRTSTS(LRWLC,1,LRAA)
|
|---|
| 38 | . F D GTWLN Q:LREND D Q:$O(LRTSTS(LRWLC,1,LRAA,0))<1
|
|---|
| 39 | . . D STWLN,ST2,^LRWLST11,EN^LA7ADL(LRUID),SICA^LRWLST11
|
|---|
| 40 | Q
|
|---|
| 41 | ;
|
|---|
| 42 | ;
|
|---|
| 43 | STWLN ; Set accession number
|
|---|
| 44 | ;
|
|---|
| 45 | D GETLOCK(LRAA,LRAD)
|
|---|
| 46 | D CHECK68(LRAA,LRAD)
|
|---|
| 47 | ;
|
|---|
| 48 | S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
|
|---|
| 49 | ;
|
|---|
| 50 | ; Handle 'in common' area that was not setup in GTWLN call.
|
|---|
| 51 | I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN)) D SETAN(LRAA,LRAD,LRAN)
|
|---|
| 52 | ;
|
|---|
| 53 | S LREND=0,LRLBLBP=1-$P(LRSS,U,2),LRSS=$P(LRSS,U)
|
|---|
| 54 | S LRACC=$P(^LRO(68,LRAA,0),U,11)_" "_$S(LRAD["0000":$E(LRAD,2,3),1:$E(LRAD,4,7))_" "_LRAN
|
|---|
| 55 | ;
|
|---|
| 56 | S LRPRAC=""
|
|---|
| 57 | I $D(^LRO(69,LRODT,1,LRSN,0)) S LRPRAC=$P(^(0),U,6) S:$D(LRNT) ^(3)=LRNT
|
|---|
| 58 | ;
|
|---|
| 59 | ; Location type
|
|---|
| 60 | S LRCAPLOC=$P($G(^SC(+LROLLOC,0)),U,3)
|
|---|
| 61 | I LRCAPLOC="" S LRCAPLOC="Z"
|
|---|
| 62 | ;
|
|---|
| 63 | ; File information in file #68 for this accession
|
|---|
| 64 | N FDA,LR6802,LRDIE
|
|---|
| 65 | S LR6802=LRAN_","_LRAD_","_LRAA_","
|
|---|
| 66 | S FDA(1,68.02,LR6802,.01)=LRDFN
|
|---|
| 67 | S FDA(1,68.02,LR6802,1)=LRDPF
|
|---|
| 68 | S FDA(1,68.02,LR6802,2)=LRAD
|
|---|
| 69 | S FDA(1,68.02,LR6802,3)=LRODT
|
|---|
| 70 | S FDA(1,68.02,LR6802,4)=LRSN
|
|---|
| 71 | S FDA(1,68.02,LR6802,6)=LRLLOC
|
|---|
| 72 | S X=$G(^LRO(69,LRODT,1,LRSN,.1)) I X'="" S FDA(1,68.02,LR6802,14)=X
|
|---|
| 73 | ;
|
|---|
| 74 | ; No ordering provider/location on controls
|
|---|
| 75 | I LRDPF'=62.3 D
|
|---|
| 76 | . S FDA(1,68.02,LR6802,6.5)=LRPRAC
|
|---|
| 77 | . S FDA(1,68.02,LR6802,94)=LROLLOC
|
|---|
| 78 | ;
|
|---|
| 79 | ; Only store treating specialty on file #2 patients
|
|---|
| 80 | ; If no treating specialty then use specialty from file #44 location
|
|---|
| 81 | I LRDPF=2 D
|
|---|
| 82 | . S LRTREA=$P($G(^DPT(DFN,.103)),U)
|
|---|
| 83 | . I 'LRTREA S LRTREA=$P($G(^SC(+LROLLOC,0)),U,20)
|
|---|
| 84 | . I LRTREA S FDA(1,68.02,LR6802,6.6)=LRTREA
|
|---|
| 85 | ;
|
|---|
| 86 | S FDA(1,68.02,LR6802,6.7)=DUZ
|
|---|
| 87 | S FDA(1,68.02,LR6802,15)=LRACC
|
|---|
| 88 | S FDA(1,68.02,LR6802,26)=DUZ(2)
|
|---|
| 89 | S FDA(1,68.02,LR6802,92)=LRCAPLOC
|
|---|
| 90 | ;
|
|---|
| 91 | D FILE^DIE("","FDA(1)","LRDIE(1)")
|
|---|
| 92 | I $D(LRDIE(1)) D MAILALRT
|
|---|
| 93 | ;
|
|---|
| 94 | ; If specimen defined then set nodes, force to ien=1 since many lab
|
|---|
| 95 | ; routines expect the specimen to be record number 1.
|
|---|
| 96 | I $G(LRSPEC) D
|
|---|
| 97 | . N FDAIEN
|
|---|
| 98 | . S FDAIEN(1)=1
|
|---|
| 99 | . S FDA(2,68.05,"+1,"_LR6802,.01)=LRSPEC
|
|---|
| 100 | . S FDA(2,68.05,"+1,"_LR6802,1)=$P(LRSAMP,";",1)
|
|---|
| 101 | . D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)")
|
|---|
| 102 | . I $D(LRDIE(2)) D MAILALRT
|
|---|
| 103 | ;
|
|---|
| 104 | ; If no specimen defined then use specimen values from file #69.
|
|---|
| 105 | I $G(LRSPEC)="",$D(^LRO(69,LRODT,1,LRSN,4,0)) D
|
|---|
| 106 | . N FDA,FDAIEN,LRI,LRX
|
|---|
| 107 | . S LRI=0
|
|---|
| 108 | . F S LRI=$O(^LRO(69,LRODT,1,LRSN,4,LRI)) Q:'LRI D
|
|---|
| 109 | . . S FDAIEN(1)=LRI,LRX=$G(^LRO(69,LRODT,1,LRSN,4,LRI,0))
|
|---|
| 110 | . . S FDA(LRI,68.05,"+1,"_LR6802,.01)=$P(LRX,"^")
|
|---|
| 111 | . . D UPDATE^DIE("","FDA(LRI)","FDAIEN","LRDIE(LRI)")
|
|---|
| 112 | . . I $D(LRDIE(LRI)) D MAILALRT
|
|---|
| 113 | ;
|
|---|
| 114 | ; Create UID.
|
|---|
| 115 | S LRUID=$$LRUID^LRX(LRAA,LRAD,LRAN)
|
|---|
| 116 | ;
|
|---|
| 117 | I '$D(LRPHSET),('$G(LRQUIET)) W !!,"ACCESSION: ",LRACC," <",LRUID,">"
|
|---|
| 118 | ;
|
|---|
| 119 | D UPD696
|
|---|
| 120 | ;
|
|---|
| 121 | L -^LRO(68,LRAA,1,LRAD,1,0)
|
|---|
| 122 | Q
|
|---|
| 123 | ;
|
|---|
| 124 | ;
|
|---|
| 125 | UPD696 ; Update file #69.6 if LEDI referral patient and no existing entry
|
|---|
| 126 | K LR696IEN
|
|---|
| 127 | I $G(LRORDRR)="R" D
|
|---|
| 128 | . S LR696IEN=0
|
|---|
| 129 | . I $G(LRRSITE("SMID"))'="",$G(LRSD("RUID"))'="" S LR696IEN=+$O(^LRO(69.6,"AD",LRRSITE("SMID"),LRSD("RUID"),0))
|
|---|
| 130 | . I LR696IEN Q
|
|---|
| 131 | . I '$G(LRRSTAT(0)) S LRRSTAT(0)=$$FIND1^DIC(64.061,"","OMX","Specimen in process","","I $P(^LAB(64.061,Y,0),U,7)=""U""")
|
|---|
| 132 | . D PSET^LRPEND(SSN(2),+LRRSITE("RSITE"),LRSD("RUID"),+LRSD("RPSITE"),LRSPEC,LRSAMP,LRRSTAT(0),LRODT,$P(LRCDT,U),LRRSITE("SDT"),LRNT,.LROT)
|
|---|
| 133 | Q
|
|---|
| 134 | ;
|
|---|
| 135 | ;
|
|---|
| 136 | ST2 ; Find next available node in LR global
|
|---|
| 137 | ;
|
|---|
| 138 | N FDA,FDAIEN,LRDIE,LRX,LRXIDT
|
|---|
| 139 | ;
|
|---|
| 140 | ; Autopsy ("AU") is not a mulitple - do not attempt to set in ^LR global
|
|---|
| 141 | I LRSS="AU" S LRIDT=0 Q
|
|---|
| 142 | ;
|
|---|
| 143 | S LRIDT=0
|
|---|
| 144 | F D Q:LRIDT
|
|---|
| 145 | . S LRXIDT=9999999-LRCDT
|
|---|
| 146 | . L +^LR(LRDFN,LRSS,LRXIDT,0):5
|
|---|
| 147 | . I '$T S LRCDT=$$FMADD^XLFDT(LRCDT,0,0,0,1) Q
|
|---|
| 148 | . I '$D(^LR(LRDFN,LRSS,LRXIDT,0)) S LRIDT=LRXIDT Q
|
|---|
| 149 | . L -^LR(LRDFN,LRSS,LRXIDT,0)
|
|---|
| 150 | . S LRCDT=$$FMADD^XLFDT(LRCDT,0,0,0,1)
|
|---|
| 151 | ;
|
|---|
| 152 | ; Create entry in appropriate subscript in LAB DATA file (#63).
|
|---|
| 153 | S LRX=$S(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="BB":63.01,LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:0)
|
|---|
| 154 | S FDAIEN(1)=LRIDT
|
|---|
| 155 | S FDA(63,LRX,"+1,"_LRDFN_",",.01)=LRCDT
|
|---|
| 156 | S FDA(63,LRX,"+1,"_LRDFN_",",.06)=LRACC
|
|---|
| 157 | I LRSS'="CH" S FDA(63,LRX,"+1,"_LRDFN_",",.1)=LRNT
|
|---|
| 158 | I LRSS="CH" S FDA(63,LRX,"+1,"_LRDFN_",",.12)=3
|
|---|
| 159 | I LRSS="MI" S FDA(63,LRX,"+1,"_LRDFN_",",38)=3
|
|---|
| 160 | I LRX D UPDATE^DIE("","FDA(63)","FDAIEN","LRDIE(63)")
|
|---|
| 161 | I $D(LRDIE(63)) D MAILALRT
|
|---|
| 162 | ;
|
|---|
| 163 | ; Uncomment following code when new field .9 in"MI" subscript is released
|
|---|
| 164 | ;I LRSS="MI" D
|
|---|
| 165 | ;. N LRN,ERR,IENS
|
|---|
| 166 | ;. S IENS=LRIDT_","_LRDFN_",",LRN=0
|
|---|
| 167 | ;. F S LRN=$O(^LRO(69,LRODT,1,LRSN,2,LRN)) Q:LRN<1 D
|
|---|
| 168 | ;. . I '$D(^LRO(69,LRODT,1,LRSN,2,LRN,1,0)) Q
|
|---|
| 169 | ;. . D WP^DIE(63.05,IENS,.9,"A","^LRO(69,"_LRODT_",1,"_LRSN_",2,"_LRN_",1)","ERR")
|
|---|
| 170 | ;
|
|---|
| 171 | L -^LR(LRDFN,LRSS,LRIDT,0)
|
|---|
| 172 | ;
|
|---|
| 173 | Q
|
|---|
| 174 | ;
|
|---|
| 175 | ;
|
|---|
| 176 | GTWLN ;
|
|---|
| 177 | N X
|
|---|
| 178 | ;
|
|---|
| 179 | ; Execute accession transform for this area.
|
|---|
| 180 | S LRAN=0
|
|---|
| 181 | S X=$G(^LRO(68,LRWLC,.1)) X:X'="" X
|
|---|
| 182 | ;
|
|---|
| 183 | D GETLOCK(LRWLC,LRAD)
|
|---|
| 184 | D CHECK68(LRWLC,LRAD)
|
|---|
| 185 | ;
|
|---|
| 186 | S:'LRAN LRAN=1+$P($G(^LRO(68,LRWLC,1,LRAD,1,0)),U,3)
|
|---|
| 187 | ;
|
|---|
| 188 | I "CYEMSP"'[LRSS F Q:'$D(^LRO(68,LRWLC,1,LRAD,1,LRAN)) S LRAN=LRAN+1
|
|---|
| 189 | ;
|
|---|
| 190 | ; check for AP Accessions
|
|---|
| 191 | I "CYEMSP"[LRSS F Q:'$D(^LRO(68,LRWLC,1,LRAD,1,LRAN))&'$D(^LR("A"_LRSS_"A",$E(LRAD,1,3),LRAN)) S LRAN=LRAN+1
|
|---|
| 192 | ;
|
|---|
| 193 | I '$D(LRPHSET),$D(LRNCWL)!$P(^LAB(69.9,1,0),U,8) D ASK Q:LREND
|
|---|
| 194 | ;
|
|---|
| 195 | D SETAN(LRWLC,LRAD,LRAN)
|
|---|
| 196 | ;
|
|---|
| 197 | L -^LRO(68,LRWLC,1,LRAD,1,0)
|
|---|
| 198 | Q
|
|---|
| 199 | ;
|
|---|
| 200 | ;
|
|---|
| 201 | ASK ;
|
|---|
| 202 | ; Don't ask if tasked or a "silent" call
|
|---|
| 203 | I $D(ZTQUEUED)!($G(LRQUIET)) Q
|
|---|
| 204 | ;
|
|---|
| 205 | N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LROK,LRANX,X,Y
|
|---|
| 206 | S LROK=0
|
|---|
| 207 | F D Q:LREND!(LROK)
|
|---|
| 208 | . K DIR
|
|---|
| 209 | . S DIR(0)="NO^1:"_$S($P(LRLABKY,U,2):999999,1:LRAN)_":0"
|
|---|
| 210 | . S DIR("A")="Force to",DIR("B")=LRAN
|
|---|
| 211 | . D ^DIR
|
|---|
| 212 | . I $D(DIRUT) S LREND=1 Q
|
|---|
| 213 | . S LRANX=Y
|
|---|
| 214 | . I LRANX<+$P($G(^LRO(68,LRWLC,1,LRAD,1,0)),U,3) D
|
|---|
| 215 | . . W !,"This accession number may be already assigned either in this "
|
|---|
| 216 | . . W !,"area or a common accession area."
|
|---|
| 217 | . I $D(^LRO(68,LRWLC,1,LRAD,1,LRANX,0)) D Q:'LROK
|
|---|
| 218 | . . N LRDFNX S LRDFNX=LRDFN
|
|---|
| 219 | . . N DFN,LRDFN,LRDPF,PNM,SSN
|
|---|
| 220 | . . S LRDFN=+^LRO(68,LRWLC,1,LRAD,1,LRANX,0),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^LR(LRDFN,0),U,3)
|
|---|
| 221 | . . D PT^LRX
|
|---|
| 222 | . . W !,"THIS NUMBER BELONGS TO ",!,PNM," SSN: ",SSN
|
|---|
| 223 | . . D INF^LRX
|
|---|
| 224 | . . I LRDFN=LRDFNX S LROK=1
|
|---|
| 225 | . K DIR
|
|---|
| 226 | . S DIR(0)="YO",DIR("A")="Are you sure",DIR("B")="NO"
|
|---|
| 227 | . D ^DIR
|
|---|
| 228 | . I $D(DIRUT) S LREND=1 Q
|
|---|
| 229 | . I Y=1 S LRAN=LRANX,LROK=1
|
|---|
| 230 | ;
|
|---|
| 231 | ; Unlock if aborting.
|
|---|
| 232 | I LREND L -^LRO(68,LRWLC,1,LRAD,1,0)
|
|---|
| 233 | ;
|
|---|
| 234 | Q
|
|---|
| 235 | ;
|
|---|
| 236 | ;
|
|---|
| 237 | CHECK68(LRAA,LRAD) ; Check for/set header node of ^LRO(68) 68.01 subfile.
|
|---|
| 238 | ;
|
|---|
| 239 | ; Call with LRAA = ien of entry in file #68
|
|---|
| 240 | ; LRAD = accession date in fileman format
|
|---|
| 241 | ;
|
|---|
| 242 | ; Set accession date in file #68 for this acession.
|
|---|
| 243 | ; Check for existence of accession number multiple but not accession date multiple,
|
|---|
| 244 | ; FileMan DBS call fails when accession number multiple exists but accession date multiple does not.
|
|---|
| 245 | ; If this condition found then set missing node directly and quit.
|
|---|
| 246 | ;
|
|---|
| 247 | I '$D(^LRO(68,LRAA,1,LRAD,0)) D
|
|---|
| 248 | . N FDA,FDAIEN,LRDIE,X
|
|---|
| 249 | . S X=$Q(^LRO(68,LRAA,1,LRAD,0))
|
|---|
| 250 | . I X'="",$QS(X,4)=LRAD S $P(^LRO(68,LRAA,1,LRAD,0),"^")=LRAD Q
|
|---|
| 251 | . S (FDAIEN(1),FDA(1,68.01,"+1,"_LRAA_",",.01))=LRAD
|
|---|
| 252 | . D UPDATE^DIE("","FDA(1)","FDAIEN","LRDIE(1)")
|
|---|
| 253 | . I $D(LRDIE(1)) D MAILALRT
|
|---|
| 254 | ;
|
|---|
| 255 | Q
|
|---|
| 256 | ;
|
|---|
| 257 | ;
|
|---|
| 258 | GETLOCK(LRAA,LRAD) ; Obtain lock on zeroth node of this accession date
|
|---|
| 259 | ; Call with LRAA = ien of entry in file #68
|
|---|
| 260 | ; LRAD = accession date in fileman format
|
|---|
| 261 | ;
|
|---|
| 262 | F L +^LRO(68,LRAA,1,LRAD,1,0):10 Q:$T D
|
|---|
| 263 | . I $D(ZTQUEUED)!($G(LRQUIET)) Q
|
|---|
| 264 | . W !!?5,"Accession area ",$P(^LRO(68,LRAA,0),"^")," is locked by another user.",!,$C(7)
|
|---|
| 265 | Q
|
|---|
| 266 | ;
|
|---|
| 267 | ;
|
|---|
| 268 | SETAN(LRAA,LRAD,LRAN) ; Create stub entry in file #68 for this acession.
|
|---|
| 269 | ;
|
|---|
| 270 | ; Call with LRAA = ien of entry in file #68
|
|---|
| 271 | ; LRAD = accession date in fileman format
|
|---|
| 272 | ; LRAN = accession number
|
|---|
| 273 | ;
|
|---|
| 274 | N FDA,FDAIEN,LR6802,LRDIE
|
|---|
| 275 | ;
|
|---|
| 276 | S LR6802=LRAD_","_LRAA_","
|
|---|
| 277 | S FDAIEN(1)=LRAN
|
|---|
| 278 | S FDA(2,68.02,"+1,"_LR6802,.01)=LRDFN
|
|---|
| 279 | D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)")
|
|---|
| 280 | I $D(LRDIE(2)) D MAILALRT
|
|---|
| 281 | Q
|
|---|
| 282 | ;
|
|---|
| 283 | ;
|
|---|
| 284 | MAILALRT ; Send mail message alert when FileMan DBS errors returned
|
|---|
| 285 | ;
|
|---|
| 286 | N J,LR68,LRCNT,LRMTXT,X,XMINSTR,XMSUB,XMTO
|
|---|
| 287 | ;
|
|---|
| 288 | I $D(^LRO(68,LRAA,1,LRAD,1,LRAN)) M LR68=^LRO(68,LRAA,1,LRAD,1,LRAN)
|
|---|
| 289 | ;
|
|---|
| 290 | S LRMTXT(1)="The following debugging information is provided to assist"
|
|---|
| 291 | S LRMTXT(2)="support staff in resolving error during accessioning."
|
|---|
| 292 | S LRMTXT(3)=" "
|
|---|
| 293 | S LRCNT=3
|
|---|
| 294 | ;
|
|---|
| 295 | F J="FDA","FDAIEN","LR68","LRAA","LRAD","LRAN","LRDFN","LRDIE","LRSS","LRTSTS","LRUNQ","LRWLC","XQY","XQY0" D
|
|---|
| 296 | . S X=$G(@J)
|
|---|
| 297 | . I X'="" S LRCNT=LRCNT+1,LRMTXT(LRCNT)=J_"="_X
|
|---|
| 298 | . F S J=$Q(@J) Q:J="" S LRCNT=LRCNT+1,LRMTXT(LRCNT)=J_"="_@J
|
|---|
| 299 | ;
|
|---|
| 300 | S XMSUB="FileMan DBS call failed during accessioning in routine LRWLST1"
|
|---|
| 301 | S XMTO("G.LMI")=""
|
|---|
| 302 | S XMINSTR("FROM")=.5
|
|---|
| 303 | S XMINSTR("ADDR FLAGS")="R"
|
|---|
| 304 | D SENDMSG^XMXAPI(DUZ,XMSUB,"LRMTXT",.XMTO,.XMINSTR)
|
|---|
| 305 | Q
|
|---|
