LRWLST1 ;DALOI/STAFF - ACCESSION SETUP ;11/20/12 16:10
;;5.2;LAB SERVICE;**48,65,121,153,261,286,331,379,415,350,427**;Sep 27, 1994;Build 33
;
S LRWLC=0
F S LRWLC=$O(LRTSTS(LRWLC)) Q:LRWLC<1 S LRAD=DT D SPLIT
;
; If LEDI and comments came with order then copy to order in #69
I $G(LRORDRR)="R",$G(LR696),$D(^LRO(69.6,LR696,99)) D
. N LRDIE
. D WP^DIE(69.01,LRSN_","_LRODT_",",16,"A","^LRO(69.6,LR696,99)","LRDIE(16)")
;
K DIC,DLAYGO,DR,DA,DIE,LRIXX
Q:$G(LRORDR)="P"
K LRNM,LRTSTS
K ^TMP("LR",$J,"TMP")
Q
;
SPLIT ;
N LRAA,LRX
; Setup regular accessions (LRUNQ=0)
S LRUNQ=0,LREND=0
I $D(LRTSTS(LRWLC,0)) D
. S LRSS=$P(^LRO(68,LRWLC,0),"^",2)
. D GTWLN
. I LREND Q
. S LRAA=0
. F S LRAA=$O(LRTSTS(LRWLC,0,LRAA)) Q:LRAA<1 D
. . S LRSS=LRTSTS(LRWLC,0,LRAA)
. . D STWLN,ST2,^LRWLST11,EN^LA7ADL(LRUID)
. D SICA^LRWLST11
;
; Setup accessions requiring 'unique' accession numbers (LRUNQ=1)
S LRUNQ=1,LRAA=0
F S LRAA=$O(LRTSTS(LRWLC,1,LRAA)) Q:LRAA<1 D
. S LRSS=LRTSTS(LRWLC,1,LRAA)
. F D GTWLN Q:LREND D Q:$O(LRTSTS(LRWLC,1,LRAA,0))<1
. . D STWLN,ST2,^LRWLST11,EN^LA7ADL(LRUID),SICA^LRWLST11
Q
;
;
STWLN ; Set accession number
;
D GETLOCK(LRAA,LRAD)
D CHECK68(LRAA,LRAD)
;
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
;
; Handle 'in common' area that was not setup in GTWLN call.
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN)) D SETAN(LRAA,LRAD,LRAN)
;
S LREND=0,LRLBLBP=1-$P(LRSS,U,2),LRSS=$P(LRSS,U)
S LRACC=$P(^LRO(68,LRAA,0),U,11)_" "_$S(LRAD["0000":$E(LRAD,2,3),1:$E(LRAD,4,7))_" "_LRAN
S LRPRAC=""
I $D(^LRO(69,LRODT,1,LRSN,0)) S LRPRAC=$P(^(0),U,6) S:$D(LRNT) ^(3)=LRNT
;
; Location type
S LRCAPLOC=$P($G(^SC(+LROLLOC,0)),U,3)
I LRCAPLOC="" S LRCAPLOC="Z"
;
; File information in file #68 for this accession
N LRFDA,LR6802,LRDIE
S LR6802=LRAN_","_LRAD_","_LRAA_","
S LRFDA(1,68.02,LR6802,.01)=LRDFN
S LRFDA(1,68.02,LR6802,1)=LRDPF
S LRFDA(1,68.02,LR6802,2)=LRAD
S LRFDA(1,68.02,LR6802,3)=LRODT
S LRFDA(1,68.02,LR6802,4)=LRSN
S LRFDA(1,68.02,LR6802,6)=LRLLOC
S X=$G(^LRO(69,LRODT,1,LRSN,.1)) I X'="" S LRFDA(1,68.02,LR6802,14)=X
;
; No ordering provider/location on controls
I LRDPF'=62.3 D
. S LRFDA(1,68.02,LR6802,6.5)=LRPRAC
. S LRFDA(1,68.02,LR6802,94)=LROLLOC
;
; Only store treating specialty on file #2 patients
; If no treating specialty then use specialty from file #44 location
I LRDPF=2 D
. S LRTREA=$P($G(^DPT(DFN,.103)),U)
. I 'LRTREA S LRTREA=$P($G(^SC(+LROLLOC,0)),U,20)
. I LRTREA S LRFDA(1,68.02,LR6802,6.6)=LRTREA
;
S LRFDA(1,68.02,LR6802,6.7)=DUZ
S LRFDA(1,68.02,LR6802,15)=LRACC
S LRFDA(1,68.02,LR6802,26)=DUZ(2)
S LRFDA(1,68.02,LR6802,92)=LRCAPLOC
D FILE^DIE("","LRFDA(1)","LRDIE(1)")
I $D(LRDIE(1)) D MAILALRT^LRWLST12("STWLN~LRWLST1")
;
; If specimen defined then set nodes, force to ien=1 since many lab
; routines expect the specimen to be record number 1.
I $G(LRSPEC),'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)) D
. N LRFDAIEN,LRLOCKOK,LRLOOPCT
. S LRFDAIEN(1)=1
. S LRFDA(2,68.05,"+1,"_LR6802,.01)=LRSPEC
. S LRFDA(2,68.05,"+1,"_LR6802,1)=$P(LRSAMP,";",1)
. ;
. ; Modification to prevent lock failures - loop 10 times to give system a chance to get lock
. S LRLOCKOK=0
. F LRLOOPCT=1:1:10 D Q:LRLOCKOK
. . D UPDATE^DIE("","LRFDA(2)","LRFDAIEN","LRDIE(2)")
. . I $G(LRDIE(2,"DIERR")),LRDIE(2,"DIERR",1)<120 H 5 K:LRLOOPCT<10 LRDIE(2)
. . E S LRLOCKOK=1
. ;
. I $D(LRDIE(2)) D MAILALRT^LRWLST12("STWLN~LRWLST1")
;
; If no specimen defined then use specimen values from file #69.
I $G(LRSPEC)="",$D(^LRO(69,LRODT,1,LRSN,4,0)) D
. N LRFDA,LRFDAIEN,LRI,LRX
. S LRI=0
. F S LRI=$O(^LRO(69,LRODT,1,LRSN,4,LRI)) Q:'LRI D
. . I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,5,LRI,0)) Q
. . S LRFDAIEN(1)=LRI,LRX=$G(^LRO(69,LRODT,1,LRSN,4,LRI,0))
. . S LRFDA(LRI,68.05,"+1,"_LR6802,.01)=$P(LRX,"^")
. . D UPDATE^DIE("","LRFDA(LRI)","LRFDAIEN","LRDIE(LRI)")
. . I $D(LRDIE(LRI)) D MAILALRT^LRWLST12("STWLN~LRWLST1")
;
; Create UID.
S LRUID=$$LRUID^LRX(LRAA,LRAD,LRAN)
I '$D(LRPHSET),('$G(LRQUIET)) W !!,"ACCESSION: ",LRACC," <",LRUID,">"
D UPD696
;
L -^LRO(68,LRAA,1,LRAD,1,0)
Q
;
;
UPD696 ; Update file #69.6 if LEDI referral patient and no existing entry
K LR696IEN
I $G(LRORDRR)="R" D
. S LR696IEN=0
. I $G(LRRSITE("SMID"))'="",$G(LRSD("RUID"))'="" S LR696IEN=+$O(^LRO(69.6,"AD",LRRSITE("SMID"),LRSD("RUID"),0))
. I LR696IEN Q
. 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""")
. D PSET^LRPEND(SSN(2),+LRRSITE("RSITE"),LRSD("RUID"),+LRSD("RPSITE"),LRSPEC,LRSAMP,LRRSTAT(0),LRODT,$P(LRCDT,U),LRRSITE("SDT"),LRNT,.LROT)
Q
;
;
ST2 ; Find next available node in LR global
;
N LRFDA,LRFDAIEN,LRDIE,LRX,LRXIDT
; Autopsy ("AU") is not a multiple - do not attempt to set in ^LR global
I LRSS="AU" S LRIDT=0 Q
;
S LRIDT=0
F D Q:LRIDT
. S LRXIDT=9999999-LRCDT
. L +^LR(LRDFN,LRSS,LRXIDT,0):5
. I '$T S LRCDT=$$FMADD^XLFDT(LRCDT,0,0,0,1) Q
. I '$D(^LR(LRDFN,LRSS,LRXIDT,0)) S LRIDT=LRXIDT Q
. L -^LR(LRDFN,LRSS,LRXIDT,0)
. S LRCDT=$$FMADD^XLFDT(LRCDT,0,0,0,1)
;
; Create entry in appropriate subscript in LAB DATA file (#63).
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)
S LRFDAIEN(1)=LRIDT
S LRFDA(63,LRX,"+1,"_LRDFN_",",.01)=LRCDT
S LRFDA(63,LRX,"+1,"_LRDFN_",",.06)=LRACC
I LRSS'="CH" D
. S LRFDA(63,LRX,"+1,"_LRDFN_",",.1)=LRNT
. S LRFDA(63,LRX,"+1,"_LRDFN_",",.08)=LRLLOC
I LRSS="CH" D
. S LRFDA(63,LRX,"+1,"_LRDFN_",",.12)=3
. S LRFDA(63,LRX,"+1,"_LRDFN_",",.11)=LRLLOC
I LRSS="MI" S LRFDA(63,LRX,"+1,"_LRDFN_",",38)=3
I "SPCYEM"[LRSS N LRABV S LRABV=$P(LRACC," ")
I LRX D UPDATE^DIE("","LRFDA(63)","LRFDAIEN","LRDIE(63)")
I $D(LRDIE(63)) D MAILALRT^LRWLST12("ST2~LRWLST1")
;
; Uncomment following code when new field .9 in"MI" subscript is released
;I LRSS="MI" D
;. N LRN,ERR,IENS
;. S IENS=LRIDT_","_LRDFN_",",LRN=0
;. F S LRN=$O(^LRO(69,LRODT,1,LRSN,2,LRN)) Q:LRN<1 D
;. . I '$D(^LRO(69,LRODT,1,LRSN,2,LRN,1,0)) Q
;. . D WP^DIE(63.05,IENS,.9,"A","^LRO(69,"_LRODT_",1,"_LRSN_",2,"_LRN_",1)","ERR")
;
L -^LR(LRDFN,LRSS,LRIDT,0)
;
Q
;
;
GTWLN ;
N LRABV,X
;
; Execute accession transform for this area.
S LRAN=0
S X=$G(^LRO(68,LRWLC,.1)) X:X'="" X
;
D GETLOCK(LRWLC,LRAD)
D CHECK68(LRWLC,LRAD)
;
; note LRSS can at this point can contain two pieces in the variable.
S:'LRAN LRAN=1+$P($G(^LRO(68,LRWLC,1,LRAD,1,0)),U,3)
I $P(LRSS,"^")?1(1"CH",1"MI",1"BB") F Q:('$D(^LRO(68,LRWLC,1,LRAD,1,LRAN)))&($$ORIGAAOK) S LRAN=LRAN+1
;
; Check for AP Accessions
S LRABV=$P($G(^LRO(68,LRWLC,0)),U,11)
I $P(LRSS,"^")?1(1"SP",1"CY",1"EM",1"AU") F Q:'$D(^LRO(68,LRWLC,1,LRAD,1,LRAN))&('$D(^LR("A"_$P(LRSS,"^")_"A",$E(LRAD,1,3),LRABV,LRAN)))&($$ORIGAAOK) S LRAN=LRAN+1
;
I '$D(LRPHSET),$D(LRNCWL)!$P(^LAB(69.9,1,0),U,8) D ASK Q:LREND
;
I '$D(^LRO(68,LRWLC,1,LRAD,1,LRAN)) D SETAN(LRWLC,LRAD,LRAN)
L -^LRO(68,LRWLC,1,LRAD,1,0)
Q
;
;
ORIGAAOK() ; function to determine if the accession number under consideration
; is already in use in the originating accession area
;
; returns 0 -- accession number under consideration already in use
; 1 -- accession number under consideration is ok to use
;
N LRAAX,LRAAOK,LRABVX,LRAA0,LRSSX
S LRAAX=0,LRAAOK=1
;
F S LRAAX=$O(LRTSTS(LRWLC,LRUNQ,LRAAX)) Q:LRAAX<1 Q:'LRAAOK D
. I $D(^LRO(68,LRAAX,1,LRAD,1,LRAN)) S LRAAOK=0 Q
. S LRAA0=^LRO(68,LRAAX,0),LRSSX=$P(LRAA0,"^",2)
. I "CYEMSP"[LRSSX D
. . S LRABVX=$P(LRAA0,"^",11)
. . I $D(^LR("A"_LRSSX_"A",$E(LRAD,1,3),LRABVX,LRAN)) S LRAAOK=0
;
Q LRAAOK
;
;
ASK ;
; Don't ask if tasked or a "silent" call
I $D(ZTQUEUED)!($G(LRQUIET)) Q
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LROK,LRANX,X,Y
S LROK=0
F D Q:LREND!(LROK)
. K DIR
. S DIR(0)="NO^1:"_$S($P(LRLABKY,U,2):999999,1:LRAN)_":0"
. S DIR("A")="Force to",DIR("B")=LRAN
. D ^DIR
. I $D(DIRUT) S LREND=1 Q
. S LRANX=Y
. I LRANX<+$P($G(^LRO(68,LRWLC,1,LRAD,1,0)),U,3) D
. . W !,"This accession number may be already assigned either in this "
. . W !,"area or a common accession area."
. I $D(^LRO(68,LRWLC,1,LRAD,1,LRANX,0)) D Q:'LROK
. . N LRDFNX S LRDFNX=LRDFN
. . N DFN,LRDFN,LRDPF,PNM,SSN
. . S LRDFN=+^LRO(68,LRWLC,1,LRAD,1,LRANX,0),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^LR(LRDFN,0),U,3)
. . D PT^LRX
. . W !,"THIS NUMBER BELONGS TO ",!,PNM," SSN: ",SSN
. . D INF^LRX
. . I LRDFN=LRDFNX S LROK=1
. K DIR
. S DIR(0)="YO",DIR("A")="Are you sure",DIR("B")="NO"
. D ^DIR
. I $D(DIRUT) S LREND=1 Q
. I Y=1 S LRAN=LRANX,LROK=1
;
; Unlock if aborting.
I LREND L -^LRO(68,LRWLC,1,LRAD,1,0)
;
Q
;
;
CHECK68(LRAA,LRAD) ; Check for/set header node of ^LRO(68) 68.01 subfile.
;
; Call with LRAA = ien of entry in file #68
; LRAD = accession date in fileman format
;
; Set accession date in file #68 for this accession.
; Check for existence of accession number multiple but not accession date multiple,
; FileMan DBS call fails when accession number multiple exists but accession date multiple does not.
; If this condition found then set missing node directly and quit.
;
I '$D(^LRO(68,LRAA,1,LRAD,0)) D
. N LRFDA,LRFDAIEN,LRDIE,X
. S X=$Q(^LRO(68,LRAA,1,LRAD,0))
. I X'="",$QS(X,4)=LRAD S $P(^LRO(68,LRAA,1,LRAD,0),"^")=LRAD Q
. S (LRFDAIEN(1),LRFDA(1,68.01,"+1,"_LRAA_",",.01))=LRAD
. D UPDATE^DIE("","LRFDA(1)","LRFDAIEN","LRDIE(1)")
. I $D(LRDIE(1)) D MAILALRT^LRWLST12("CHECK~LRWLST1")
;
Q
;
;
GETLOCK(LRAA,LRAD) ; Obtain lock on zeroth node of this accession date
; Call with LRAA = ien of entry in file #68
; LRAD = accession date in fileman format
;
F L +^LRO(68,LRAA,1,LRAD,1,0):10 Q:$T D
. I $D(ZTQUEUED)!($G(LRQUIET)) Q
. W !!?5,"Accession area ",$P(^LRO(68,LRAA,0),"^")," is locked by another user.",!,$C(7)
Q
;
;
SETAN(LRAA,LRAD,LRAN) ; Create stub entry in file #68 for this accession.
;
; Call with LRAA = ien of entry in file #68
; LRAD = accession date in fileman format
; LRAN = accession number
;
N LR6802,LRFDA,LRFDAIEN,LRDIE,LRLOCKOK,LRLOOPCT
S LR6802=LRAD_","_LRAA_","
S LRFDAIEN(1)=LRAN
S LRFDA(2,68.02,"+1,"_LR6802,.01)=LRDFN
;
; Modification to prevent lock failures - loop 10 times to give system a chance to get lock
S LRLOCKOK=0
F LRLOOPCT=1:1:10 D Q:LRLOCKOK
. D UPDATE^DIE("","LRFDA(2)","LRFDAIEN","LRDIE(2)")
. I $G(LRDIE(2,"DIERR")),LRDIE(2,"DIERR",1)<120 H 5 K:LRLOOPCT<10 LRDIE(2)
. E S LRLOCKOK=1
;
I $D(LRDIE(2)) D MAILALRT^LRWLST12("SET~LRWLST1")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRWLST1 10804 printed Apr 09, 2024@21:07:26 Page 2
LRWLST1 ;DALOI/STAFF - ACCESSION SETUP ;11/20/12 16:10
+1 ;;5.2;LAB SERVICE;**48,65,121,153,261,286,331,379,415,350,427**;Sep 27, 1994;Build 33
+2 ;
+3 SET LRWLC=0
+4 FOR
SET LRWLC=$ORDER(LRTSTS(LRWLC))
if LRWLC<1
QUIT
SET LRAD=DT
DO SPLIT
+5 ;
+6 ; If LEDI and comments came with order then copy to order in #69
+7 IF $GET(LRORDRR)="R"
IF $GET(LR696)
IF $DATA(^LRO(69.6,LR696,99))
Begin DoDot:1
+8 NEW LRDIE
+9 DO WP^DIE(69.01,LRSN_","_LRODT_",",16,"A","^LRO(69.6,LR696,99)","LRDIE(16)")
End DoDot:1
+10 ;
+11 KILL DIC,DLAYGO,DR,DA,DIE,LRIXX
+12 if $GET(LRORDR)="P"
QUIT
+13 KILL LRNM,LRTSTS
+14 KILL ^TMP("LR",$JOB,"TMP")
+15 QUIT
+16 ;
SPLIT ;
+1 NEW LRAA,LRX
+2 ; Setup regular accessions (LRUNQ=0)
+3 SET LRUNQ=0
SET LREND=0
+4 IF $DATA(LRTSTS(LRWLC,0))
Begin DoDot:1
+5 SET LRSS=$PIECE(^LRO(68,LRWLC,0),"^",2)
+6 DO GTWLN
+7 IF LREND
QUIT
+8 SET LRAA=0
+9 FOR
SET LRAA=$ORDER(LRTSTS(LRWLC,0,LRAA))
if LRAA<1
QUIT
Begin DoDot:2
+10 SET LRSS=LRTSTS(LRWLC,0,LRAA)
+11 DO STWLN
DO ST2
DO ^LRWLST11
DO EN^LA7ADL(LRUID)
End DoDot:2
+12 DO SICA^LRWLST11
End DoDot:1
+13 ;
+14 ; Setup accessions requiring 'unique' accession numbers (LRUNQ=1)
+15 SET LRUNQ=1
SET LRAA=0
+16 FOR
SET LRAA=$ORDER(LRTSTS(LRWLC,1,LRAA))
if LRAA<1
QUIT
Begin DoDot:1
+17 SET LRSS=LRTSTS(LRWLC,1,LRAA)
+18 FOR
DO GTWLN
if LREND
QUIT
Begin DoDot:2
+19 DO STWLN
DO ST2
DO ^LRWLST11
DO EN^LA7ADL(LRUID)
DO SICA^LRWLST11
End DoDot:2
if $ORDER(LRTSTS(LRWLC,1,LRAA,0))<1
QUIT
End DoDot:1
+20 QUIT
+21 ;
+22 ;
STWLN ; Set accession number
+1 ;
+2 DO GETLOCK(LRAA,LRAD)
+3 DO CHECK68(LRAA,LRAD)
+4 ;
+5 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+6 ;
+7 ; Handle 'in common' area that was not setup in GTWLN call.
+8 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN))
DO SETAN(LRAA,LRAD,LRAN)
+9 ;
+10 SET LREND=0
SET LRLBLBP=1-$PIECE(LRSS,U,2)
SET LRSS=$PIECE(LRSS,U)
+11 SET LRACC=$PIECE(^LRO(68,LRAA,0),U,11)_" "_$SELECT(LRAD["0000":$EXTRACT(LRAD,2,3),1:$EXTRACT(LRAD,4,7))_" "_LRAN
+12 SET LRPRAC=""
+13 IF $DATA(^LRO(69,LRODT,1,LRSN,0))
SET LRPRAC=$PIECE(^(0),U,6)
if $DATA(LRNT)
SET ^(3)=LRNT
+14 ;
+15 ; Location type
+16 SET LRCAPLOC=$PIECE($GET(^SC(+LROLLOC,0)),U,3)
+17 IF LRCAPLOC=""
SET LRCAPLOC="Z"
+18 ;
+19 ; File information in file #68 for this accession
+20 NEW LRFDA,LR6802,LRDIE
+21 SET LR6802=LRAN_","_LRAD_","_LRAA_","
+22 SET LRFDA(1,68.02,LR6802,.01)=LRDFN
+23 SET LRFDA(1,68.02,LR6802,1)=LRDPF
+24 SET LRFDA(1,68.02,LR6802,2)=LRAD
+25 SET LRFDA(1,68.02,LR6802,3)=LRODT
+26 SET LRFDA(1,68.02,LR6802,4)=LRSN
+27 SET LRFDA(1,68.02,LR6802,6)=LRLLOC
+28 SET X=$GET(^LRO(69,LRODT,1,LRSN,.1))
IF X'=""
SET LRFDA(1,68.02,LR6802,14)=X
+29 ;
+30 ; No ordering provider/location on controls
+31 IF LRDPF'=62.3
Begin DoDot:1
+32 SET LRFDA(1,68.02,LR6802,6.5)=LRPRAC
+33 SET LRFDA(1,68.02,LR6802,94)=LROLLOC
End DoDot:1
+34 ;
+35 ; Only store treating specialty on file #2 patients
+36 ; If no treating specialty then use specialty from file #44 location
+37 IF LRDPF=2
Begin DoDot:1
+38 SET LRTREA=$PIECE($GET(^DPT(DFN,.103)),U)
+39 IF 'LRTREA
SET LRTREA=$PIECE($GET(^SC(+LROLLOC,0)),U,20)
+40 IF LRTREA
SET LRFDA(1,68.02,LR6802,6.6)=LRTREA
End DoDot:1
+41 ;
+42 SET LRFDA(1,68.02,LR6802,6.7)=DUZ
+43 SET LRFDA(1,68.02,LR6802,15)=LRACC
+44 SET LRFDA(1,68.02,LR6802,26)=DUZ(2)
+45 SET LRFDA(1,68.02,LR6802,92)=LRCAPLOC
+46 DO FILE^DIE("","LRFDA(1)","LRDIE(1)")
+47 IF $DATA(LRDIE(1))
DO MAILALRT^LRWLST12("STWLN~LRWLST1")
+48 ;
+49 ; If specimen defined then set nodes, force to ien=1 since many lab
+50 ; routines expect the specimen to be record number 1.
+51 IF $GET(LRSPEC)
IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0))
Begin DoDot:1
+52 NEW LRFDAIEN,LRLOCKOK,LRLOOPCT
+53 SET LRFDAIEN(1)=1
+54 SET LRFDA(2,68.05,"+1,"_LR6802,.01)=LRSPEC
+55 SET LRFDA(2,68.05,"+1,"_LR6802,1)=$PIECE(LRSAMP,";",1)
+56 ;
+57 ; Modification to prevent lock failures - loop 10 times to give system a chance to get lock
+58 SET LRLOCKOK=0
+59 FOR LRLOOPCT=1:1:10
Begin DoDot:2
+60 DO UPDATE^DIE("","LRFDA(2)","LRFDAIEN","LRDIE(2)")
+61 IF $GET(LRDIE(2,"DIERR"))
IF LRDIE(2,"DIERR",1)<120
HANG 5
if LRLOOPCT<10
KILL LRDIE(2)
+62 IF '$TEST
SET LRLOCKOK=1
End DoDot:2
if LRLOCKOK
QUIT
+63 ;
+64 IF $DATA(LRDIE(2))
DO MAILALRT^LRWLST12("STWLN~LRWLST1")
End DoDot:1
+65 ;
+66 ; If no specimen defined then use specimen values from file #69.
+67 IF $GET(LRSPEC)=""
IF $DATA(^LRO(69,LRODT,1,LRSN,4,0))
Begin DoDot:1
+68 NEW LRFDA,LRFDAIEN,LRI,LRX
+69 SET LRI=0
+70 FOR
SET LRI=$ORDER(^LRO(69,LRODT,1,LRSN,4,LRI))
if 'LRI
QUIT
Begin DoDot:2
+71 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,5,LRI,0))
QUIT
+72 SET LRFDAIEN(1)=LRI
SET LRX=$GET(^LRO(69,LRODT,1,LRSN,4,LRI,0))
+73 SET LRFDA(LRI,68.05,"+1,"_LR6802,.01)=$PIECE(LRX,"^")
+74 DO UPDATE^DIE("","LRFDA(LRI)","LRFDAIEN","LRDIE(LRI)")
+75 IF $DATA(LRDIE(LRI))
DO MAILALRT^LRWLST12("STWLN~LRWLST1")
End DoDot:2
End DoDot:1
+76 ;
+77 ; Create UID.
+78 SET LRUID=$$LRUID^LRX(LRAA,LRAD,LRAN)
+79 IF '$DATA(LRPHSET)
IF ('$GET(LRQUIET))
WRITE !!,"ACCESSION: ",LRACC," <",LRUID,">"
+80 DO UPD696
+81 ;
+82 LOCK -^LRO(68,LRAA,1,LRAD,1,0)
+83 QUIT
+84 ;
+85 ;
UPD696 ; Update file #69.6 if LEDI referral patient and no existing entry
+1 KILL LR696IEN
+2 IF $GET(LRORDRR)="R"
Begin DoDot:1
+3 SET LR696IEN=0
+4 IF $GET(LRRSITE("SMID"))'=""
IF $GET(LRSD("RUID"))'=""
SET LR696IEN=+$ORDER(^LRO(69.6,"AD",LRRSITE("SMID"),LRSD("RUID"),0))
+5 IF LR696IEN
QUIT
+6 IF '$GET(LRRSTAT(0))
SET LRRSTAT(0)=$$FIND1^DIC(64.061,"","OMX","Specimen in process","","I $P(^LAB(64.061,Y,0),U,7)=""U""")
+7 DO PSET^LRPEND(SSN(2),+LRRSITE("RSITE"),LRSD("RUID"),+LRSD("RPSITE"),LRSPEC,LRSAMP,LRRSTAT(0),LRODT,$PIECE(LRCDT,U),LRRSITE("SDT"),LRNT,.LROT)
End DoDot:1
+8 QUIT
+9 ;
+10 ;
ST2 ; Find next available node in LR global
+1 ;
+2 NEW LRFDA,LRFDAIEN,LRDIE,LRX,LRXIDT
+3 ; Autopsy ("AU") is not a multiple - do not attempt to set in ^LR global
+4 IF LRSS="AU"
SET LRIDT=0
QUIT
+5 ;
+6 SET LRIDT=0
+7 FOR
Begin DoDot:1
+8 SET LRXIDT=9999999-LRCDT
+9 LOCK +^LR(LRDFN,LRSS,LRXIDT,0):5
+10 IF '$TEST
SET LRCDT=$$FMADD^XLFDT(LRCDT,0,0,0,1)
QUIT
+11 IF '$DATA(^LR(LRDFN,LRSS,LRXIDT,0))
SET LRIDT=LRXIDT
QUIT
+12 LOCK -^LR(LRDFN,LRSS,LRXIDT,0)
+13 SET LRCDT=$$FMADD^XLFDT(LRCDT,0,0,0,1)
End DoDot:1
if LRIDT
QUIT
+14 ;
+15 ; Create entry in appropriate subscript in LAB DATA file (#63).
+16 SET LRX=$SELECT(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)
+17 SET LRFDAIEN(1)=LRIDT
+18 SET LRFDA(63,LRX,"+1,"_LRDFN_",",.01)=LRCDT
+19 SET LRFDA(63,LRX,"+1,"_LRDFN_",",.06)=LRACC
+20 IF LRSS'="CH"
Begin DoDot:1
+21 SET LRFDA(63,LRX,"+1,"_LRDFN_",",.1)=LRNT
+22 SET LRFDA(63,LRX,"+1,"_LRDFN_",",.08)=LRLLOC
End DoDot:1
+23 IF LRSS="CH"
Begin DoDot:1
+24 SET LRFDA(63,LRX,"+1,"_LRDFN_",",.12)=3
+25 SET LRFDA(63,LRX,"+1,"_LRDFN_",",.11)=LRLLOC
End DoDot:1
+26 IF LRSS="MI"
SET LRFDA(63,LRX,"+1,"_LRDFN_",",38)=3
+27 IF "SPCYEM"[LRSS
NEW LRABV
SET LRABV=$PIECE(LRACC," ")
+28 IF LRX
DO UPDATE^DIE("","LRFDA(63)","LRFDAIEN","LRDIE(63)")
+29 IF $DATA(LRDIE(63))
DO MAILALRT^LRWLST12("ST2~LRWLST1")
+30 ;
+31 ; Uncomment following code when new field .9 in"MI" subscript is released
+32 ;I LRSS="MI" D
+33 ;. N LRN,ERR,IENS
+34 ;. S IENS=LRIDT_","_LRDFN_",",LRN=0
+35 ;. F S LRN=$O(^LRO(69,LRODT,1,LRSN,2,LRN)) Q:LRN<1 D
+36 ;. . I '$D(^LRO(69,LRODT,1,LRSN,2,LRN,1,0)) Q
+37 ;. . D WP^DIE(63.05,IENS,.9,"A","^LRO(69,"_LRODT_",1,"_LRSN_",2,"_LRN_",1)","ERR")
+38 ;
+39 LOCK -^LR(LRDFN,LRSS,LRIDT,0)
+40 ;
+41 QUIT
+42 ;
+43 ;
GTWLN ;
+1 NEW LRABV,X
+2 ;
+3 ; Execute accession transform for this area.
+4 SET LRAN=0
+5 SET X=$GET(^LRO(68,LRWLC,.1))
if X'=""
XECUTE X
+6 ;
+7 DO GETLOCK(LRWLC,LRAD)
+8 DO CHECK68(LRWLC,LRAD)
+9 ;
+10 ; note LRSS can at this point can contain two pieces in the variable.
+11 if 'LRAN
SET LRAN=1+$PIECE($GET(^LRO(68,LRWLC,1,LRAD,1,0)),U,3)
+12 IF $PIECE(LRSS,"^")?1(1"CH",1"MI",1"BB")
FOR
if ('$DATA(^LRO(68,LRWLC,1,LRAD,1,LRAN)))&($$ORIGAAOK)
QUIT
SET LRAN=LRAN+1
+13 ;
+14 ; Check for AP Accessions
+15 SET LRABV=$PIECE($GET(^LRO(68,LRWLC,0)),U,11)
+16 IF $PIECE(LRSS,"^")?1(1"SP",1"CY",1"EM",1"AU")
FOR
if '$DATA(^LRO(68,LRWLC,1,LRAD,1,LRAN))&('$DATA(^LR("A"_$PIECE(LRSS,"^")_"A",$EXTRACT(LRAD,1,3),LRABV,LRAN)))&($$ORIGAAOK)
QUIT
SET LRAN=LRAN+1
+17 ;
+18 IF '$DATA(LRPHSET)
IF $DATA(LRNCWL)!$PIECE(^LAB(69.9,1,0),U,8)
DO ASK
if LREND
QUIT
+19 ;
+20 IF '$DATA(^LRO(68,LRWLC,1,LRAD,1,LRAN))
DO SETAN(LRWLC,LRAD,LRAN)
+21 LOCK -^LRO(68,LRWLC,1,LRAD,1,0)
+22 QUIT
+23 ;
+24 ;
ORIGAAOK() ; function to determine if the accession number under consideration
+1 ; is already in use in the originating accession area
+2 ;
+3 ; returns 0 -- accession number under consideration already in use
+4 ; 1 -- accession number under consideration is ok to use
+5 ;
+6 NEW LRAAX,LRAAOK,LRABVX,LRAA0,LRSSX
+7 SET LRAAX=0
SET LRAAOK=1
+8 ;
+9 FOR
SET LRAAX=$ORDER(LRTSTS(LRWLC,LRUNQ,LRAAX))
if LRAAX<1
QUIT
if 'LRAAOK
QUIT
Begin DoDot:1
+10 IF $DATA(^LRO(68,LRAAX,1,LRAD,1,LRAN))
SET LRAAOK=0
QUIT
+11 SET LRAA0=^LRO(68,LRAAX,0)
SET LRSSX=$PIECE(LRAA0,"^",2)
+12 IF "CYEMSP"[LRSSX
Begin DoDot:2
+13 SET LRABVX=$PIECE(LRAA0,"^",11)
+14 IF $DATA(^LR("A"_LRSSX_"A",$EXTRACT(LRAD,1,3),LRABVX,LRAN))
SET LRAAOK=0
End DoDot:2
End DoDot:1
+15 ;
+16 QUIT LRAAOK
+17 ;
+18 ;
ASK ;
+1 ; Don't ask if tasked or a "silent" call
+2 IF $DATA(ZTQUEUED)!($GET(LRQUIET))
QUIT
+3 ;
+4 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LROK,LRANX,X,Y
+5 SET LROK=0
+6 FOR
Begin DoDot:1
+7 KILL DIR
+8 SET DIR(0)="NO^1:"_$SELECT($PIECE(LRLABKY,U,2):999999,1:LRAN)_":0"
+9 SET DIR("A")="Force to"
SET DIR("B")=LRAN
+10 DO ^DIR
+11 IF $DATA(DIRUT)
SET LREND=1
QUIT
+12 SET LRANX=Y
+13 IF LRANX<+$PIECE($GET(^LRO(68,LRWLC,1,LRAD,1,0)),U,3)
Begin DoDot:2
+14 WRITE !,"This accession number may be already assigned either in this "
+15 WRITE !,"area or a common accession area."
End DoDot:2
+16 IF $DATA(^LRO(68,LRWLC,1,LRAD,1,LRANX,0))
Begin DoDot:2
+17 NEW LRDFNX
SET LRDFNX=LRDFN
+18 NEW DFN,LRDFN,LRDPF,PNM,SSN
+19 SET LRDFN=+^LRO(68,LRWLC,1,LRAD,1,LRANX,0)
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^LR(LRDFN,0),U,3)
+20 DO PT^LRX
+21 WRITE !,"THIS NUMBER BELONGS TO ",!,PNM," SSN: ",SSN
+22 DO INF^LRX
+23 IF LRDFN=LRDFNX
SET LROK=1
End DoDot:2
if 'LROK
QUIT
+24 KILL DIR
+25 SET DIR(0)="YO"
SET DIR("A")="Are you sure"
SET DIR("B")="NO"
+26 DO ^DIR
+27 IF $DATA(DIRUT)
SET LREND=1
QUIT
+28 IF Y=1
SET LRAN=LRANX
SET LROK=1
End DoDot:1
if LREND!(LROK)
QUIT
+29 ;
+30 ; Unlock if aborting.
+31 IF LREND
LOCK -^LRO(68,LRWLC,1,LRAD,1,0)
+32 ;
+33 QUIT
+34 ;
+35 ;
CHECK68(LRAA,LRAD) ; Check for/set header node of ^LRO(68) 68.01 subfile.
+1 ;
+2 ; Call with LRAA = ien of entry in file #68
+3 ; LRAD = accession date in fileman format
+4 ;
+5 ; Set accession date in file #68 for this accession.
+6 ; Check for existence of accession number multiple but not accession date multiple,
+7 ; FileMan DBS call fails when accession number multiple exists but accession date multiple does not.
+8 ; If this condition found then set missing node directly and quit.
+9 ;
+10 IF '$DATA(^LRO(68,LRAA,1,LRAD,0))
Begin DoDot:1
+11 NEW LRFDA,LRFDAIEN,LRDIE,X
+12 SET X=$QUERY(^LRO(68,LRAA,1,LRAD,0))
+13 IF X'=""
IF $QSUBSCRIPT(X,4)=LRAD
SET $PIECE(^LRO(68,LRAA,1,LRAD,0),"^")=LRAD
QUIT
+14 SET (LRFDAIEN(1),LRFDA(1,68.01,"+1,"_LRAA_",",.01))=LRAD
+15 DO UPDATE^DIE("","LRFDA(1)","LRFDAIEN","LRDIE(1)")
+16 IF $DATA(LRDIE(1))
DO MAILALRT^LRWLST12("CHECK~LRWLST1")
End DoDot:1
+17 ;
+18 QUIT
+19 ;
+20 ;
GETLOCK(LRAA,LRAD) ; Obtain lock on zeroth node of this accession date
+1 ; Call with LRAA = ien of entry in file #68
+2 ; LRAD = accession date in fileman format
+3 ;
+4 FOR
LOCK +^LRO(68,LRAA,1,LRAD,1,0):10
if $TEST
QUIT
Begin DoDot:1
+5 IF $DATA(ZTQUEUED)!($GET(LRQUIET))
QUIT
+6 WRITE !!?5,"Accession area ",$PIECE(^LRO(68,LRAA,0),"^")," is locked by another user.",!,$CHAR(7)
End DoDot:1
+7 QUIT
+8 ;
+9 ;
SETAN(LRAA,LRAD,LRAN) ; Create stub entry in file #68 for this accession.
+1 ;
+2 ; Call with LRAA = ien of entry in file #68
+3 ; LRAD = accession date in fileman format
+4 ; LRAN = accession number
+5 ;
+6 NEW LR6802,LRFDA,LRFDAIEN,LRDIE,LRLOCKOK,LRLOOPCT
+7 SET LR6802=LRAD_","_LRAA_","
+8 SET LRFDAIEN(1)=LRAN
+9 SET LRFDA(2,68.02,"+1,"_LR6802,.01)=LRDFN
+10 ;
+11 ; Modification to prevent lock failures - loop 10 times to give system a chance to get lock
+12 SET LRLOCKOK=0
+13 FOR LRLOOPCT=1:1:10
Begin DoDot:1
+14 DO UPDATE^DIE("","LRFDA(2)","LRFDAIEN","LRDIE(2)")
+15 IF $GET(LRDIE(2,"DIERR"))
IF LRDIE(2,"DIERR",1)<120
HANG 5
if LRLOOPCT<10
KILL LRDIE(2)
+16 IF '$TEST
SET LRLOCKOK=1
End DoDot:1
if LRLOCKOK
QUIT
+17 ;
+18 IF $DATA(LRDIE(2))
DO MAILALRT^LRWLST12("SET~LRWLST1")
+19 QUIT
