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