Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRWLST1

LRWLST1.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  S LRWLC=0
  1.  F  S LRWLC=$O(LRTSTS(LRWLC)) Q:LRWLC<1  S LRAD=DT D SPLIT
  1.  ;
  1.  ; If LEDI and comments came with order then copy to order in #69
  1.  I $G(LRORDRR)="R",$G(LR696),$D(^LRO(69.6,LR696,99)) D
  1.  . N LRDIE
  1.  . D WP^DIE(69.01,LRSN_","_LRODT_",",16,"A","^LRO(69.6,LR696,99)","LRDIE(16)")
  1.  ;
  1.  K DIC,DLAYGO,DR,DA,DIE,LRIXX
  1.  Q:$G(LRORDR)="P"
  1.  K LRNM,LRTSTS
  1.  K ^TMP("LR",$J,"TMP")
  1.  Q
  1.  ;
  1. SPLIT ;
  1.  N LRAA,LRX
  1.  ; Setup regular accessions (LRUNQ=0)
  1.  S LRUNQ=0,LREND=0
  1.  I $D(LRTSTS(LRWLC,0)) D
  1.  . S LRSS=$P(^LRO(68,LRWLC,0),"^",2)
  1.  . D GTWLN
  1.  . I LREND Q
  1.  . S LRAA=0
  1.  . F  S LRAA=$O(LRTSTS(LRWLC,0,LRAA)) Q:LRAA<1  D
  1.  . . S LRSS=LRTSTS(LRWLC,0,LRAA)
  1.  . . D STWLN,ST2,^LRWLST11,EN^LA7ADL(LRUID)
  1.  . D SICA^LRWLST11
  1.  ;
  1.  ; Setup accessions requiring 'unique' accession numbers (LRUNQ=1)
  1.  S LRUNQ=1,LRAA=0
  1.  F  S LRAA=$O(LRTSTS(LRWLC,1,LRAA)) Q:LRAA<1  D
  1.  . S LRSS=LRTSTS(LRWLC,1,LRAA)
  1.  . F  D GTWLN Q:LREND  D   Q:$O(LRTSTS(LRWLC,1,LRAA,0))<1
  1.  . . D STWLN,ST2,^LRWLST11,EN^LA7ADL(LRUID),SICA^LRWLST11
  1.  Q
  1.  ;
  1.  ;
  1. STWLN ; Set accession number
  1.  ;
  1.  D GETLOCK(LRAA,LRAD)
  1.  D CHECK68(LRAA,LRAD)
  1.  ;
  1.  S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
  1.  ;
  1.  ; Handle 'in common' area that was not setup in GTWLN call.
  1.  I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN)) D SETAN(LRAA,LRAD,LRAN)
  1.  ;
  1.  S LREND=0,LRLBLBP=1-$P(LRSS,U,2),LRSS=$P(LRSS,U)
  1.  S LRACC=$P(^LRO(68,LRAA,0),U,11)_" "_$S(LRAD["0000":$E(LRAD,2,3),1:$E(LRAD,4,7))_" "_LRAN
  1.  S LRPRAC=""
  1.  I $D(^LRO(69,LRODT,1,LRSN,0)) S LRPRAC=$P(^(0),U,6) S:$D(LRNT) ^(3)=LRNT
  1.  ;
  1.  ; Location type
  1.  S LRCAPLOC=$P($G(^SC(+LROLLOC,0)),U,3)
  1.  I LRCAPLOC="" S LRCAPLOC="Z"
  1.  ;
  1.  ; File information in file #68 for this accession
  1.  N LRFDA,LR6802,LRDIE
  1.  S LR6802=LRAN_","_LRAD_","_LRAA_","
  1.  S LRFDA(1,68.02,LR6802,.01)=LRDFN
  1.  S LRFDA(1,68.02,LR6802,1)=LRDPF
  1.  S LRFDA(1,68.02,LR6802,2)=LRAD
  1.  S LRFDA(1,68.02,LR6802,3)=LRODT
  1.  S LRFDA(1,68.02,LR6802,4)=LRSN
  1.  S LRFDA(1,68.02,LR6802,6)=LRLLOC
  1.  S X=$G(^LRO(69,LRODT,1,LRSN,.1)) I X'="" S LRFDA(1,68.02,LR6802,14)=X
  1.  ;
  1.  ; No ordering provider/location on controls
  1.  I LRDPF'=62.3 D
  1.  . S LRFDA(1,68.02,LR6802,6.5)=LRPRAC
  1.  . S LRFDA(1,68.02,LR6802,94)=LROLLOC
  1.  ;
  1.  ; Only store treating specialty on file #2 patients
  1.  ; If no treating specialty then use specialty from file #44 location
  1.  I LRDPF=2 D
  1.  . S LRTREA=$P($G(^DPT(DFN,.103)),U)
  1.  . I 'LRTREA S LRTREA=$P($G(^SC(+LROLLOC,0)),U,20)
  1.  . I LRTREA S LRFDA(1,68.02,LR6802,6.6)=LRTREA
  1.  ;
  1.  S LRFDA(1,68.02,LR6802,6.7)=DUZ
  1.  S LRFDA(1,68.02,LR6802,15)=LRACC
  1.  S LRFDA(1,68.02,LR6802,26)=DUZ(2)
  1.  S LRFDA(1,68.02,LR6802,92)=LRCAPLOC
  1.  D FILE^DIE("","LRFDA(1)","LRDIE(1)")
  1.  I $D(LRDIE(1)) D MAILALRT^LRWLST12("STWLN~LRWLST1")
  1.  ;
  1.  ; If specimen defined then set nodes, force to ien=1 since many lab
  1.  ; routines expect the specimen to be record number 1.
  1.  I $G(LRSPEC),'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)) D
  1.  . N LRFDAIEN,LRLOCKOK,LRLOOPCT
  1.  . S LRFDAIEN(1)=1
  1.  . S LRFDA(2,68.05,"+1,"_LR6802,.01)=LRSPEC
  1.  . S LRFDA(2,68.05,"+1,"_LR6802,1)=$P(LRSAMP,";",1)
  1.  . ;
  1.  . ; Modification to prevent lock failures - loop 10 times to give system a chance to get lock
  1.  . S LRLOCKOK=0
  1.  . F LRLOOPCT=1:1:10 D  Q:LRLOCKOK
  1.  . . D UPDATE^DIE("","LRFDA(2)","LRFDAIEN","LRDIE(2)")
  1.  . . I $G(LRDIE(2,"DIERR")),LRDIE(2,"DIERR",1)<120  H 5 K:LRLOOPCT<10 LRDIE(2)
  1.  . . E  S LRLOCKOK=1
  1.  . ;
  1.  . I $D(LRDIE(2)) D MAILALRT^LRWLST12("STWLN~LRWLST1")
  1.  ;
  1.  ; If no specimen defined then use specimen values from file #69.
  1.  I $G(LRSPEC)="",$D(^LRO(69,LRODT,1,LRSN,4,0)) D
  1.  . N LRFDA,LRFDAIEN,LRI,LRX
  1.  . S LRI=0
  1.  . F  S LRI=$O(^LRO(69,LRODT,1,LRSN,4,LRI)) Q:'LRI  D
  1.  . . I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,5,LRI,0)) Q
  1.  . . S LRFDAIEN(1)=LRI,LRX=$G(^LRO(69,LRODT,1,LRSN,4,LRI,0))
  1.  . . S LRFDA(LRI,68.05,"+1,"_LR6802,.01)=$P(LRX,"^")
  1.  . . D UPDATE^DIE("","LRFDA(LRI)","LRFDAIEN","LRDIE(LRI)")
  1.  . . I $D(LRDIE(LRI)) D MAILALRT^LRWLST12("STWLN~LRWLST1")
  1.  ;
  1.  ; Create UID.
  1.  S LRUID=$$LRUID^LRX(LRAA,LRAD,LRAN)
  1.  I '$D(LRPHSET),('$G(LRQUIET)) W !!,"ACCESSION:  ",LRACC,"  <",LRUID,">"
  1.  D UPD696
  1.  ;
  1.  L -^LRO(68,LRAA,1,LRAD,1,0)
  1.  Q
  1.  ;
  1.  ;
  1. UPD696 ; Update file #69.6 if LEDI referral patient and no existing entry
  1.  K LR696IEN
  1.  I $G(LRORDRR)="R" D
  1.  . S LR696IEN=0
  1.  . I $G(LRRSITE("SMID"))'="",$G(LRSD("RUID"))'="" S LR696IEN=+$O(^LRO(69.6,"AD",LRRSITE("SMID"),LRSD("RUID"),0))
  1.  . I LR696IEN Q
  1.  . 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""")
  1.  . D PSET^LRPEND(SSN(2),+LRRSITE("RSITE"),LRSD("RUID"),+LRSD("RPSITE"),LRSPEC,LRSAMP,LRRSTAT(0),LRODT,$P(LRCDT,U),LRRSITE("SDT"),LRNT,.LROT)
  1.  Q
  1.  ;
  1.  ;
  1. ST2 ; Find next available node in LR global
  1.  ;
  1.  N LRFDA,LRFDAIEN,LRDIE,LRX,LRXIDT
  1.  ; Autopsy ("AU") is not a multiple - do not attempt to set in ^LR global
  1.  I LRSS="AU" S LRIDT=0 Q
  1.  ;
  1.  S LRIDT=0
  1.  F  D  Q:LRIDT
  1.  . S LRXIDT=9999999-LRCDT
  1.  . L +^LR(LRDFN,LRSS,LRXIDT,0):5
  1.  . I '$T S LRCDT=$$FMADD^XLFDT(LRCDT,0,0,0,1) Q
  1.  . I '$D(^LR(LRDFN,LRSS,LRXIDT,0)) S LRIDT=LRXIDT Q
  1.  . L -^LR(LRDFN,LRSS,LRXIDT,0)
  1.  . S LRCDT=$$FMADD^XLFDT(LRCDT,0,0,0,1)
  1.  ;
  1.  ; Create entry in appropriate subscript in LAB DATA file (#63).
  1.  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)
  1.  S LRFDAIEN(1)=LRIDT
  1.  S LRFDA(63,LRX,"+1,"_LRDFN_",",.01)=LRCDT
  1.  S LRFDA(63,LRX,"+1,"_LRDFN_",",.06)=LRACC
  1.  I LRSS'="CH" D
  1.  . S LRFDA(63,LRX,"+1,"_LRDFN_",",.1)=LRNT
  1.  . S LRFDA(63,LRX,"+1,"_LRDFN_",",.08)=LRLLOC
  1.  I LRSS="CH" D
  1.  . S LRFDA(63,LRX,"+1,"_LRDFN_",",.12)=3
  1.  . S LRFDA(63,LRX,"+1,"_LRDFN_",",.11)=LRLLOC
  1.  I LRSS="MI" S LRFDA(63,LRX,"+1,"_LRDFN_",",38)=3
  1.  I "SPCYEM"[LRSS N LRABV S LRABV=$P(LRACC," ")
  1.  I LRX D UPDATE^DIE("","LRFDA(63)","LRFDAIEN","LRDIE(63)")
  1.  I $D(LRDIE(63)) D MAILALRT^LRWLST12("ST2~LRWLST1")
  1.  ;
  1.  ; Uncomment following code when new field .9 in"MI" subscript is released
  1.  ;I LRSS="MI" D
  1.  ;. N LRN,ERR,IENS
  1.  ;. S IENS=LRIDT_","_LRDFN_",",LRN=0
  1.  ;. F  S LRN=$O(^LRO(69,LRODT,1,LRSN,2,LRN)) Q:LRN<1  D
  1.  ;. . I '$D(^LRO(69,LRODT,1,LRSN,2,LRN,1,0)) Q
  1.  ;. . D WP^DIE(63.05,IENS,.9,"A","^LRO(69,"_LRODT_",1,"_LRSN_",2,"_LRN_",1)","ERR")
  1.  ;
  1.  L -^LR(LRDFN,LRSS,LRIDT,0)
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. GTWLN ;
  1.  N LRABV,X
  1.  ;
  1.  ; Execute accession transform for this area.
  1.  S LRAN=0
  1.  S X=$G(^LRO(68,LRWLC,.1)) X:X'="" X
  1.  ;
  1.  D GETLOCK(LRWLC,LRAD)
  1.  D CHECK68(LRWLC,LRAD)
  1.  ;
  1.  ; note LRSS can at this point can contain two pieces in the variable.
  1.  S:'LRAN LRAN=1+$P($G(^LRO(68,LRWLC,1,LRAD,1,0)),U,3)
  1.  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
  1.  ;
  1.  ; Check for AP Accessions
  1.  S LRABV=$P($G(^LRO(68,LRWLC,0)),U,11)
  1.  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
  1.  ;
  1.  I '$D(LRPHSET),$D(LRNCWL)!$P(^LAB(69.9,1,0),U,8) D ASK Q:LREND
  1.  ;
  1.  I '$D(^LRO(68,LRWLC,1,LRAD,1,LRAN)) D SETAN(LRWLC,LRAD,LRAN)
  1.  L -^LRO(68,LRWLC,1,LRAD,1,0)
  1.  Q
  1.  ;
  1.  ;
  1. ORIGAAOK() ; function to determine if the accession number under consideration
  1.  ; is already in use in the originating accession area
  1.  ;
  1.  ; returns 0 -- accession number under consideration already in use
  1.  ;         1 -- accession number under consideration is ok to use
  1.  ;
  1.  N LRAAX,LRAAOK,LRABVX,LRAA0,LRSSX
  1.  S LRAAX=0,LRAAOK=1
  1.  ;
  1.  F  S LRAAX=$O(LRTSTS(LRWLC,LRUNQ,LRAAX)) Q:LRAAX<1  Q:'LRAAOK  D
  1.  . I $D(^LRO(68,LRAAX,1,LRAD,1,LRAN)) S LRAAOK=0 Q
  1.  . S LRAA0=^LRO(68,LRAAX,0),LRSSX=$P(LRAA0,"^",2)
  1.  . I "CYEMSP"[LRSSX D
  1.  . . S LRABVX=$P(LRAA0,"^",11)
  1.  . . I $D(^LR("A"_LRSSX_"A",$E(LRAD,1,3),LRABVX,LRAN)) S LRAAOK=0
  1.  ;
  1.  Q LRAAOK
  1.  ;
  1.  ;
  1. ASK ;
  1.  ; Don't ask if tasked or a "silent" call
  1.  I $D(ZTQUEUED)!($G(LRQUIET)) Q
  1.  ;
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LROK,LRANX,X,Y
  1.  S LROK=0
  1.  F  D  Q:LREND!(LROK)
  1.  . K DIR
  1.  . S DIR(0)="NO^1:"_$S($P(LRLABKY,U,2):999999,1:LRAN)_":0"
  1.  . S DIR("A")="Force to",DIR("B")=LRAN
  1.  . D ^DIR
  1.  . I $D(DIRUT) S LREND=1 Q
  1.  . S LRANX=Y
  1.  . I LRANX<+$P($G(^LRO(68,LRWLC,1,LRAD,1,0)),U,3) D
  1.  . . W !,"This accession number may be already assigned either in this "
  1.  . . W !,"area or a common accession area."
  1.  . I $D(^LRO(68,LRWLC,1,LRAD,1,LRANX,0)) D  Q:'LROK
  1.  . . N LRDFNX S LRDFNX=LRDFN
  1.  . . N DFN,LRDFN,LRDPF,PNM,SSN
  1.  . . S LRDFN=+^LRO(68,LRWLC,1,LRAD,1,LRANX,0),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^LR(LRDFN,0),U,3)
  1.  . . D PT^LRX
  1.  . . W !,"THIS NUMBER BELONGS TO ",!,PNM,"     SSN: ",SSN
  1.  . . D INF^LRX
  1.  . . I LRDFN=LRDFNX S LROK=1
  1.  . K DIR
  1.  . S DIR(0)="YO",DIR("A")="Are you sure",DIR("B")="NO"
  1.  . D ^DIR
  1.  . I $D(DIRUT) S LREND=1 Q
  1.  . I Y=1 S LRAN=LRANX,LROK=1
  1.  ;
  1.  ; Unlock if aborting.
  1.  I LREND L -^LRO(68,LRWLC,1,LRAD,1,0)
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. CHECK68(LRAA,LRAD) ; Check for/set header node of ^LRO(68) 68.01 subfile.
  1.  ;
  1.  ; Call with LRAA = ien of entry in file #68
  1.  ;           LRAD = accession date in fileman format
  1.  ;
  1.  ; Set accession date in file #68 for this accession.
  1.  ; Check for existence of accession number multiple but not accession date multiple,
  1.  ; FileMan DBS call fails when accession number multiple exists but accession date multiple does not.
  1.  ; If this condition found then set missing node directly and quit.
  1.  ;
  1.  I '$D(^LRO(68,LRAA,1,LRAD,0)) D
  1.  . N LRFDA,LRFDAIEN,LRDIE,X
  1.  . S X=$Q(^LRO(68,LRAA,1,LRAD,0))
  1.  . I X'="",$QS(X,4)=LRAD S $P(^LRO(68,LRAA,1,LRAD,0),"^")=LRAD Q
  1.  . S (LRFDAIEN(1),LRFDA(1,68.01,"+1,"_LRAA_",",.01))=LRAD
  1.  . D UPDATE^DIE("","LRFDA(1)","LRFDAIEN","LRDIE(1)")
  1.  . I $D(LRDIE(1)) D MAILALRT^LRWLST12("CHECK~LRWLST1")
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. GETLOCK(LRAA,LRAD) ; Obtain lock on zeroth node of this accession date
  1.  ; Call with LRAA = ien of entry in file #68
  1.  ;           LRAD = accession date in fileman format
  1.  ;
  1.  F  L +^LRO(68,LRAA,1,LRAD,1,0):10 Q:$T  D
  1.  . I $D(ZTQUEUED)!($G(LRQUIET)) Q
  1.  . W !!?5,"Accession area ",$P(^LRO(68,LRAA,0),"^")," is locked by another user.",!,$C(7)
  1.  Q
  1.  ;
  1.  ;
  1. SETAN(LRAA,LRAD,LRAN) ; Create stub entry in file #68 for this accession.
  1.  ;
  1.  ; Call with LRAA = ien of entry in file #68
  1.  ;           LRAD = accession date in fileman format
  1.  ;           LRAN = accession number
  1.  ;
  1.  N LR6802,LRFDA,LRFDAIEN,LRDIE,LRLOCKOK,LRLOOPCT
  1.  S LR6802=LRAD_","_LRAA_","
  1.  S LRFDAIEN(1)=LRAN
  1.  S LRFDA(2,68.02,"+1,"_LR6802,.01)=LRDFN
  1.  ;
  1.  ; Modification to prevent lock failures - loop 10 times to give system a chance to get lock
  1.  S LRLOCKOK=0
  1.  F LRLOOPCT=1:1:10 D  Q:LRLOCKOK
  1.  . D UPDATE^DIE("","LRFDA(2)","LRFDAIEN","LRDIE(2)")
  1.  . I $G(LRDIE(2,"DIERR")),LRDIE(2,"DIERR",1)<120  H 5 K:LRLOOPCT<10 LRDIE(2)
  1.  . E  S LRLOCKOK=1
  1.  ;
  1.  I $D(LRDIE(2)) D MAILALRT^LRWLST12("SET~LRWLST1")
  1.  Q