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

LRWLST12.m

Go to the documentation of this file. 
  1. LRWLST12 ;DALOI/STAFF - ACCESSION SETUP ;8/19/2013
  1.  ;;5.2;LAB SERVICE;**153,201,350,427**;Sep 27, 1994;Build 33
  1.  ;
  1.  ;
  1. CAP ; from LRWLST11,LRTSTJAM
  1.  N LRCNT
  1.  Q:'($D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2)
  1.  S:'($D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))#2) ^(0)="^68.04PA" S $P(^(0),U,3)=+LRTS,$P(^(0),U,4)=1+$P(^(0),U,4)
  1.  S:'($D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRTS,0))#2) ^(0)=LRTS,$P(^(0),U,9)=+$G(LRTSORU)
  1.  S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",+LRTS,+LRTS)) ^(+LRTS)=""
  1.  ;
  1.  S:'$G(LRSAMP) LRSAMP=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)),U,2)
  1.  ;
  1.  I $P(LRPARAM,U,14),$P($G(^LRO(68,+LRAA,0)),U,16) D
  1.  . S LRCI=0
  1.  . F  S LRCI=$O(^LAB(60,+LRTS,9.1,LRCI)) Q:LRCI<1  I $D(^(LRCI,0)) S X=^(0),LRCNT=$S(+$P(X,U,3):+$P(X,U,3),1:1) D CAP1
  1.  I $P(LRPARAM,U,14),$P($G(^LRO(68,LRAA,0)),U,16) D
  1.  . S LRCI=0
  1.  . F  S LRCI=$O(^LAB(62,+LRSAMP,9,LRAA,1,+LRTS,1,LRCI)) Q:LRCI<1  I $D(^(LRCI,0)) S X=^(0),LRCNT=$S(+$P(X,U,3):+$P(X,U,3),1:1) D CAP1
  1.  ;
  1.  K LRCI,LRCWT,X,C3,C4,C0,LRCI,LRCNT
  1.  Q
  1.  ;
  1.  ;
  1. CAP1 ;
  1.  S LRT=+LRTS D STUFI^LRCAPV1
  1.  K LRT
  1.  I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRTS,1,0)) S ^(0)="^68.14P^^"
  1.  S C0=^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRTS,1,0),C4=$P(C0,U,4)+1,$P(C0,U,3)=LRCI,$P(C0,U,4)=C4,^(0)=C0
  1.  ;
  1. C3 ;
  1.  I '($D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRTS,1,LRCI,0))#2) D
  1.  . S:'$D(LRNT) LRNT=$$HTFM^XLFDT($H)
  1.  . S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRTS,1,LRCI,0)=LRCI_U_LRCNT_"^^^^"_LRNT_"^.5"_U_DUZ(2)_U_LRAA_U_LRAA_U
  1.  Q
  1.  ;
  1.  ;
  1. VMSG ;
  1.  N LA7V
  1.  S LA7V=""
  1.  I $G(LR696IEN),$D(^LRO(69.6,LR696IEN,0))#2 D
  1.  . S $P(^LRO(69.6,LR696IEN,0),U,10)=160,LRCNT=0
  1.  . F  S LRCNT=$O(LROT(LRSAMP,LRSPEC,LRCNT)) Q:LRCNT<1  I $D(LROT(LRSAMP,LRSPEC,LRCNT,"B",+LRTS))#2 D
  1.  . . S LRTSN=LROT(LRSAMP,LRSPEC,LRCNT,"B",+LRTS)
  1.  . . I $D(^LRO(69.6,LR696IEN,2,+LRTSN,0)) S $P(^(0),U,7)=LRNT,$P(^(0),U,9)=LRUID,$P(^(0),U,6)=160 D
  1.  . . . D SET^LA7VMSG($P(LRORU3,U,4),$P(LRORU3,U,2),$P(LRORU3,U,5),$P(LRORU3,U,3),$P(LRTSN,U,3),$P(LRTSN,U,2),LRIDT,LRSS,LRDFN,LRODT,,"ORR")
  1.  ;. D ORR^LA7VMSG ; Update status to in process - need to task this from another place (JMC/27NOV06)
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. ORUT2 ; Update ordered test in file #69.6
  1.  ; Called by LRWLST11
  1.  N FDA,LRDIE,LRI,LRNLT,LROK,LRSTATUS,LRUPSTAT,LRTST,LRX
  1.  S LRNLT=$$NLT^LRVER1(+LRTSORU) Q:+LRNLT<1
  1.  S LRTST=$P($G(^LAM($O(^LAM("E",LRNLT,0)),0)),U) Q:LRTST=""!('$G(LR696IEN))
  1.  ;Q:'($D(^LRO(69.6,LR696IEN,0))#2)!($D(^LRO(69.6,LR696IEN,2,"C",LRNLT)))
  1.  I '$D(^LRO(69.6,LR696IEN,0)) Q
  1.  ;
  1.  S LRUPSTAT=$$FIND1^DIC(64.061,"","OX","Specimen in process","B","I $P(^LAB(64.061,Y,0),U,7)=""U""")
  1.  ; Update existing entry with current status
  1.  I $D(^LRO(69.6,LR696IEN,2,"C",LRNLT)) D
  1.  . S LRI=$O(^LRO(69.6,LR696IEN,2,"C",LRNLT,0))
  1.  . S FDA(1,69.64,LRI_","_LR696IEN_",",5)=LRUPSTAT
  1.  . S FDA(1,69.64,LRI_","_LR696IEN_",",8)=LRNT
  1.  . S FDA(1,69.64,LRI_","_LR696IEN_",",9)=LRUID
  1.  . S FDA(1,69.64,LRI_","_LR696IEN_",",12)=LRURG
  1.  . D FILE^DIE("","FDA(1)","LRDIE(1)")
  1.  . D CLEAN^DILF
  1.  ;
  1.  ; JMC/8 Feb 07 - need to rewrite to use FileMan DBS call
  1.  ; Create new entry with current status
  1.  I '$D(^LRO(69.6,LR696IEN,2,"C",LRNLT)) D
  1.  . S:'$D(^LRO(69.6,LR696IEN,2,0)) ^(0)="^69.64A^"
  1.  . N DA,DIC,DIE,DLAYGO,DR
  1.  . S DLAYGO=69.6,DA=LR696IEN
  1.  . S LRURG=$S($L($P($G(^LAB(62.05,+$P(LRTS,U,2),0)),U,4)):$P(^(0),U,4),1:"R")
  1.  . S (DIE,DIC)="^LRO(69.6,",DIC(0)="LM"
  1.  . S DR=20_"///"_LRTST_";",DR(1,69.6)="20///"_LRTST_";"
  1.  . S DR(2,69.64)=".01///"_LRTST_";1///"_LRNLT_";4///"_LRURG_";5////160;8///"_LRNT_";9///"_LRUID
  1.  . D ^DIE
  1.  ;
  1.  ; Check and update specimen status based on test order status
  1.  ;  - if specimen status is 'in-transit' then update if all tests have been processed.
  1.  S LRX=+$P(^LRO(69.6,LR696IEN,0),U,10),LROK=1,LRSTATUS=""
  1.  I LRX S LRSTATUS=$$GET1^DIQ(64.061,LRX_",",.01)
  1.  I LRSTATUS="In-Transit" D
  1.  . S LRI=0
  1.  . F  S LRI=$O(^LRO(69.6,LR696,2,LRI)) Q:'LRI  D  Q:'LROK
  1.  . . S X=$P(^LRO(69.6,LR696,2,LRI,0),"^",6) Q:'X
  1.  . . I $$GET1^DIQ(64.061,X_",",.01)="In-Transit" S LROK=0
  1.  . I 'LROK Q
  1.  . I LRSTATUS="" Q
  1.  . S FDA(3,69.6,LR696IEN_",",6)=LRUPSTAT
  1.  . D FILE^DIE("","FDA(3)","LRDIE(3)")
  1.  . D CLEAN^DILF
  1.  Q
  1.  ;
  1.  ;
  1. PROVCPY ; Copy remote ordering provider from file #69.6 to ordered test multiple (#.35)
  1.  ; Called from LRWLST11
  1.  N FDA,LRDIE,LRFILE,LRI,LRPROV,LRX,LRY,LRZ
  1.  ;
  1.  S LRFILE=$S(LRSS="CH":63.07,LRSS="MI":63.5,LRSS="SP":63.53,LRSS="CY":63.51,LRSS="EM":63.52,1:"")
  1.  I LRFILE="" Q
  1.  S LRI=0,LRPROV=""
  1.  F  S LRI=$O(^LR(LRDFN,LRSS,LRIDT,"ORUT",LRI)) Q:'LRI  D
  1.  . S LRX=$P($G(^LR(LRDFN,LRSS,LRIDT,"ORUT",LRI,0)),"^")
  1.  . S LRY=$O(^LRO(69.6,LR696,2,"C",LRX,0))
  1.  . I LRY="" Q
  1.  . S LRZ=$P($G(^LRO(69.6,LR696,2,LRY,1)),"^")
  1.  . I LRZ="" Q
  1.  . S LRPROV=$E(LRZ,1,45)
  1.  . S FDA(1,LRFILE,LRI_","_LRIDT_","_LRDFN_",",7)=LRPROV
  1.  . D FILE^DIE("","FDA(1)","LRDIE(1)")
  1.  . K FDA(1),LRDIE(1)
  1.  ;
  1.  ; Copy ordering provider to file #63, AP field #.011 SPECIMEN SUBMITTED BY (free text field)
  1.  ;   - Copied from last or only test, only can store one.
  1.  I LRPROV'="","SPCYEM"[LRSS D
  1.  . S LRFILE=$S(LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:"")
  1.  . I LRFILE="" Q
  1.  . S FDA(2,LRFILE,LRIDT_","_LRDFN_",",.011)=LRPROV
  1.  . D FILE^DIE("","FDA(2)","LRDIE(2)")
  1.  . K FDA(2),LRDIE(2)
  1.  ;
  1.  D CLEAN^DILF
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. APMOVE ; Copy anatomic pathology data from file #69.6 to corresponding fields in file #63 for this accession.
  1.  ; Called from LRWLST11
  1.  ;
  1.  ; Copy specimen multiple to file #63
  1.  N FDA,LRDIE,LRFILE,LRI,LRX,LRY
  1.  S LRFILE=$S(LRSS="SP":63.812,LRSS="CY":63.902,LRSS="EM":63.202,1:0)
  1.  I 'LRFILE Q
  1.  S LRI=0
  1.  F  S LRI=$O(^LRO(69.6,LR696,61,LRI)) Q:'LRI  D
  1.  . N LRCYWKLD
  1.  . S LRY=$G(^LRO(69.6,LR696,61,LRI,0))
  1.  . I $P(LRY,"^")="" Q
  1.  . S FDA(1,LRFILE,"+1,"_LRIDT_","_LRDFN_",",.01)=$P(LRY,"^")
  1.  . I $P(LRY,"^",2) S FDA(1,LRFILE,"+1,"_LRIDT_","_LRDFN_",",.06)=$P(LRY,"^",2)
  1.  . I $P(LRY,"^",3) S FDA(1,LRFILE,"+1,"_LRIDT_","_LRDFN_",",.07)=$P(LRY,"^",3)
  1.  . I LRSS="CY" D
  1.  . . S LRCYWKLD=$$CYWKLD($P(LRY,"^"),$P(LRY,"^",2),$P(LRY,"^",3),LRAA)
  1.  . . I LRCYWKLD S FDA(1,LRFILE,"+1,"_LRIDT_","_LRDFN_",",.02)=LRCYWKLD
  1.  . I $D(FDA(1)) D UPDATE^DIE("","FDA(1)","","LRDIE(1)")
  1.  . K FDA(1),LRDIE(1)
  1.  ;
  1.  ; If no free text specimen and topography then create from top-level topography
  1.  I '$D(^LRO(69.6,LR696,61)) D
  1.  . N LRCYWKLD
  1.  . S LRX=$G(^LRO(69.6,LR696,0))
  1.  . I '$P(LRX,"^",7) Q
  1.  . S LRY=$$GET1^DIQ(61,$P(LRX,"^",7),.01),$P(LRY,"^",2,3)=$P(LRX,"^",7,8)
  1.  . S FDA(2,LRFILE,"+1,"_LRIDT_","_LRDFN_",",.01)=$P(LRY,"^")
  1.  . I $P(LRY,"^",2) S FDA(2,LRFILE,"+1,"_LRIDT_","_LRDFN_",",.06)=$P(LRY,"^",2)
  1.  . I $P(LRY,"^",3) S FDA(2,LRFILE,"+1,"_LRIDT_","_LRDFN_",",.07)=$P(LRY,"^",3)
  1.  . I LRSS="CY" D
  1.  . . S LRCYWKLD=$$CYWKLD($P(LRY,"^"),$P(LRY,"^",2),$P(LRY,"^",3),LRAA)
  1.  . . I LRCYWKLD S FDA(2,LRFILE,"+1,"_LRIDT_","_LRDFN_",",.02)=LRCYWKLD
  1.  . I $D(FDA(2)) D UPDATE^DIE("","FDA(2)","","LRDIE(2)")
  1.  . K FDA(2),LRDIE(2)
  1.  ;
  1.  ; Copy accompanying text to corresponding word-processing fields in file #63
  1.  ; If frozen section (1.3) and not SP subscript then store in microscopic description (1.1) - only SP supports frozen section.
  1.  S LRI=0,LRFILE=$S(LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:0)
  1.  F  S LRI=$O(^LRO(69.6,LR696,63,LRI)) Q:'LRI  D
  1.  . S LRY=+$G(^LRO(69.6,LR696,63,LRI,0))
  1.  . I '$D(^LRO(69.6,LR696,63,LRI,1)) Q
  1.  . I LRI=1.3,LRSS'="SP" S LRI=1.1
  1.  . I LRFILE D WP^DIE(LRFILE,LRIDT_","_LRDFN_",",LRY,"A","^LRO(69.6,LR696,63,LRI,1)","LRDIE(LRFILE)")
  1.  ;
  1.  D CLEAN^DILF
  1.  Q
  1.  ;
  1.  ;
  1. MAILALRT(LRRNAME,LRFMERR) ;
  1.  ; Send mail message alert when FileMan DBS errors returned
  1.  ; Inputs
  1.  ;  LRRNAME: Routine name (TAG~RTN)
  1.  ;  LRFMERR:<byref><opt> FileMan error local array
  1.  ;
  1.  N J,LR68,LRCNT,LRMTXT,X,XMINSTR,XMSUB,XMTO,Y
  1.  ;
  1.  I $D(^LRO(68,LRAA,1,LRAD,1,LRAN)) M LR68=^LRO(68,LRAA,1,LRAD,1,LRAN)
  1.  ;
  1.  S LRMTXT(1)="The following debugging information is provided to assist"
  1.  S LRMTXT(2)="support staff in resolving error during accessioning."
  1.  S LRMTXT(3)=" ",LRCNT=3
  1.  ;
  1.  F J="DILOCKTM","DUZ","FDA","FDAIEN","LR68","LRAA","LRAD","LRAN","LRDFN","LRDIE","LRFDA","LRFDAIEN","LRFMERR","LRSAMP","LRSPEC","LRSS","LRTSTS","LRUNQ","LRWLC","XQY","XQY0" D
  1.  . S X=$G(@J)
  1.  . I X'="" S LRCNT=LRCNT+1,LRMTXT(LRCNT)=J_"="_X
  1.  . F  S J=$Q(@J) Q:J=""  S LRCNT=LRCNT+1,LRMTXT(LRCNT)=J_"="_@J
  1.  S LRCNT=LRCNT+1,LRMTXT(LRCNT)="Last Global Ref="_$$LGR^%ZOSV
  1.  S LRCNT=LRCNT+1,LRMTXT(LRCNT)="Version="_$$VERSION^%ZOSV(1)_" "_$$VERSION^%ZOSV
  1.  S LRCNT=LRCNT+1,LRMTXT(LRCNT)="Operating System="_$$OS^%ZOSV
  1.  D GETENV^%ZOSV
  1.  S LRCNT=LRCNT+1,LRMTXT(LRCNT)="Environment="_Y
  1.  ;
  1.  S XMSUB="FileMan DBS call failed during accessioning in routine "_$G(LRRNAME,"LRWLST1")
  1.  I $L(XMSUB)>65 S XMSUB="FileMan DBS failed during accessioning in "_$G(LRRNAME,"LRWLST1")
  1.  S XMTO("G.LMI")="",XMINSTR("FROM")=.5,XMINSTR("ADDR FLAGS")="R"
  1.  D SENDMSG^XMXAPI(DUZ,XMSUB,"LRMTXT",.XMTO,.XMINSTR)
  1.  Q
  1. CYWKLD(LR61NAME,LR61,LR62,LRAA) ;
  1.  ;
  1.  N LRCAPA,LRCYWKLD,DIR,DA,X,Y
  1.  ;
  1.  S LRCYWKLD=0
  1.  ;
  1.  S LRCAPA=$P(^LAB(69.9,1,0),"^",14)&($P(^LRO(68,LRAA,0),"^",16))
  1.  I 'LRCAPA Q LRCYWKLD
  1.  ;
  1.  W !
  1.  W !!,"CY Workload Profile For:"
  1.  W !
  1.  W !,"            SPECIMEN: ",LR61NAME
  1.  I LR61 W !," SPECIMEN TOPOGRAPHY: ",$$GET1^DIQ(61,LR61_",",.01)
  1.  I LR62 W !,"   COLLECTION SAMPLE: ",$$GET1^DIQ(62,LR62_",",.01)
  1.  W !
  1.  ;
  1.  S DIR(0)="63.902,.02"
  1.  D ^DIR
  1.  I $D(DIRUT) Q LRCYWKLD
  1.  S LRCYWKLD=+Y
  1.  ;
  1.  Q LRCYWKLD