LRMLED ;BPFO/DTG - NTRT MESSAGE PROCESS AND EDITS UPDATE ;12/26/2016
;;5.2;LAB SERVICE;**468,500,517**;Sep 27, 1994;Build 5
;
; ESTART is called from a 'NEW' format cross reference on the 60 file AMLTFNTRT
; and will send NTRT message if appropiate.
EN(LRS,LR60IEN) ; entry point from cross reference
; only have one
L +^TMP(LR60IEN,LRS):1 I '$T Q
N ZTDTH,ZTRTN,ZTSAVE,ZTIO,ZTSK,ZTDESC
; START OF CHANGE FOR LR*5.2*500
;S ZTDTH=$$NOW^XLFDT,ZTDESC="LAB Create NTRT message from file 60 Cross Reference #491"
S B=$H,A=$$HADD^XLFDT(B,,8,,),C=$$HTFM^XLFDT(A)
S ZTDTH=C,ZTDESC="LAB Create NTRT message from file 60 Cross Reference #491"
S ZTRTN="ESTART^LRMLED("_LR60IEN_","_LRS_")",ZTSAVE("LR60IEN")="",ZTSAVE("LRS")="",ZTIO="",ZTSAVE("LRDUZ")=DUZ
D ^%ZTLOAD
L -^TMP(LR60IEN,LRS)
Q
;
ESTART(LR60IEN,LRS) ; pick up key data for NTRT
Q:$D(LRMLTFREC)
L +^TMP(LR60IEN,LRS):30 I '$T Q
;START OF CHANGE FOR LR*5.2*500
N LXA,LXB,LXC,LXG,LXD,LXE,LXF,LXH,A,B,C,D,LSITE,LRNT,LRNTI,AR,LRNLT,LRSEC,I,LRNOS1,LRNOS2
;END OF CHANGE FOR LR*5.2*500
N LRSITE,LRSITEN,LRGMAIL,LRSMAIL,LRNAMIL,LACT,MAILPERSON,LR64,LRCOM,LRCTY,LRSUBSCRIPT
N LRSCHPA,LRSCHNM,ALI,LRTEXT,LR64N,LRDTNM,G
S:$G(LRDUZ)="" LRDUZ=$G(DUZ)
I $G(DT)="" S DT=$$DT^XLFDT
D GET664
; check if allow to send to NTRT
; I $G(LRNTI(.1,"I"))'=1 G EOUT
;
;site number and name
S LRSITE=$G(LRNTI(.01,"I")),LRSITEN=$G(LRNTI(.01,"E"))
;ntrt mail group
S LRNMAIL=$G(LRNTI(1,"I"))
;lab send mail group
S LRGMAIL=$G(LRNTI(2,"I"))
;lab server side mail group
S LRSMAIL=$G(LRNTI(3,"I"))
;how to send mail
S LACT=$G(LRNTI(.02,"E"))
; get type of test to send
S LRSUBSCRIPT=$G(LRNTI(.07,"I")) I LRSUBSCRIPT="" S LRSUBSCRIPT=1 ; default to CH only
; send blood bank?
;
S DA=+LR60IEN
;get test
EA ; .01 test name, 4 subscript (CH), 5 data name, 13 field (DD of 5), 64.1 result nlt code
S DIQ="LXB",DIQ(0)="IE",DIC=60,DR=".01;4;64.1;5;13;131;132;133;134;135;137" K ^UTILITY("DIQ1",$J) D EN^DIQ1 K ^UTILITY("DIQ1",$J)
K LXA M LXA=LXB(60,DA) K LXB
D TDT
; check test subscript is valid for NTRT
S A=$G(LXA(4,"I"))
I A="WK" G EOUT ; don't send if workload
I A="AU" G EOUT
I A="EM" G EOUT
I A="BB" G EOUT
I A="CH"&((LRSUBSCRIPT=1)!(LRSUBSCRIPT=7)!(LRSUBSCRIPT=8)) G EGOOD
I A="MI"&((LRSUBSCRIPT=2)!(LRSUBSCRIPT=7)!(LRSUBSCRIPT=8)) G EGOOD
; I A="EM"&((LRSUBSCRIPT=3)!(LRSUBSCRIPT=8)) G EGOOD ; do not do AU per Leeanne 6/2016
I A="SP"&((LRSUBSCRIPT=4)!(LRSUBSCRIPT=8)) G EGOOD
I A="CY"&((LRSUBSCRIPT=5)!(LRSUBSCRIPT=8)) G EGOOD
; I A="AU"&((LRSUBSCRIPT=6)!(LRSUBSCRIPT=8)) G EGOOD ; do not do AU per Leeanne 6/2016
G EOUT ; doesn't match up
;
EGOOD ; if the subscript is valid
; check if inactive
S A=$G(LXA(132,"I")),B=$G(LXA(133,"I")) I A'=""!(B'="") G EOUT
;get synonyms
K B S LXG="",A=0 F I=0:1 S A=$O(^LAB(60,DA,5,A)) Q:'A S B(I)=$P(^LAB(60,DA,5,A,0),U,1)
I I>0 S B=I-1 F I=0:1:B D I $L(LXG)>210 Q
. I LXG="" S LXG=B(I) Q
. S LXG=LXG_U_B(I)
;get nlt number
S LR64=$G(LXA(64.1,"I")),(LRNLT,LRSEC)="",LR64N=$G(LXA(64.1,"E"))
I LR64'="" S LRNLT=$G(^LAM(LR64,0)),A=$P(LRNLT,U,15),LRNLT=$P(LRNLT,U,2)
I A'="" S LRSEC=$P($G(^LAB(64.21,A,0)),U,2)
;get comment / data type from comment
S (LRCOM,LRCTY,LRDTNM)="",A=$G(LXA(13,"I")),LRDTNM=$P($G(LXA(5,"I")),";",2)
I A'="" S B=$$ETSTTYP(A),LRCOM=$P(B,"|",1),LRCTY=$P(B,"|",2) S:$P(B,"|",3)'="" LRDTNM=LRDTNM_" - "_$P(B,"|",3)
;START OF CHANGE FOR LR*5.2*500
; get the performing labs
D LIST^DIC(60.16,","_DA_",","@;.01;1","",,,,,,,"LXB")
K LXH M LXH=LXB("DILIST","ID") K LXB
;END OF CHANGE FOR LR*5.2*500
; get specimen info
ES ; LRS is passed in and is the specimen IEN
S DIQ="LXB",DIQ(0)="IE",DIC=60,DR=100,DA=+LR60IEN K LXB,^UTILITY("DIQ1",$J)
S DR(60.01)=".01;6;1;2;9.2;9.3;13;30;32;33;34;35",DA(60.01)=LRS
D EN^DIQ1 K ^UTILITY("DIQ1",$J)
K LXC M LXC=LXB("60.01",LRS) K LXB
; get the specimen INTERPRETATION
D GETS^DIQ(60.01,LRS_","_DA,"5.5","","LXB")
K LXE M LXE=LXB(60.01,LRS_","_DA_",",5.5) K LXB
; don't do if MLTF already associated
I $G(LXC(30,"I"))'="" G EOUT
; don't do if inactive or already sent
S A=$G(LXC(32,"I")),B=$G(LXC(33,"I")),C=$G(LXC(34,"I")) I $E(A,1)="Y"!(B'="")!($E(C,1)="Y") G EOUT
;if no send method or not allowed to send to NTRT
;START OF CHANGE FOR LR*5.2*500
S LRNOS1=0 I LACT=""!($G(LRNTI(.02,"I"))="N")!($G(LRNTI(.1,"I"))'=1) S LRNOS1=1
;END OF CHANGE FOR LR*5.2*500
S A=$TR(LRGMAIL,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
S LRNOS2=0 I '$$PROD^XUPROD()!(LRGMAIL'["DOMAIN.EXT") S LRNOS2=1
I LACT=""!($E(LACT,1)="N") D MAILMAN G EOUT
D @LACT
;put exception flag in 60 file
; since making exception flag uneditable must do physical set
;START OF CHANGE FOR LR*5.2*500
;I (LRNOS1'=1&(LRNOS2'=1)) D ;<
G:'$G(^LAB(60,LR60IEN,1,LRS,0)) EOUT ; p517 exit if missing 0 node rec for SITE/SPECIMEN
N A,B,LRO,LRN,I S A=$G(^LAB(60,LR60IEN,1,LRS,5)),B=A,$P(B,U,3)="Y",^LAB(60,LR60IEN,1,LRS,5)=B
; need to build array for saving in audit section
F I=1,2,4 S LRO(I)="",LRN(I)=""
S LRO(3)=$P(A,U,3),LRN(3)=$P(B,U,3)
N ZTDTH,ZTRTN,ZTSAVE,ZTIO,ZTSK,ZTDESC
S ZTDTH=$$NOW^XLFDT,ZTDESC="LAB Edit Save of Deployed Flag"
S ZTRTN="SEDA^LRMLED("_LRS_","_LR60IEN_")",ZTSAVE("LR60IEN")="",ZTSAVE("LRS")=""
S ZTSAVE("LRN(")="",ZTSAVE("LRO(")=""
S ZTIO=""
D ^%ZTLOAD
;END OF CHANGE FOR LR*5.2*500
G EOUT
;
MAILMAN ;mailman
N XMSUB,XMY,XMTEXT,LRTEXT,XMDUZ,DA,DR,DIE
;
I LRNMAIL="" Q ; missing NTRT recipient
;
S XMSUB="NEW NTRT REQUEST FOR LABORATORY"
;S XMY(DUZ)=""
S XMY(LRDUZ)=""
; send to NTRT if ntrt mail group and send method and production/va site
I LRNMAIL'="" S XMY(LRNMAIL)="" I LRNOS1=1!(LRNOS2=1) K XMY(LRNMAIL)
;
I LRGMAIL'="" S XMDUZ("New Test/Specimen NTRT Request From: "_$E(LRSITEN,1,30))="",XMY($P(LRGMAIL,"@",1))=""
S ALI=0
I LRNOS1=1!(LRNOS2=1) D ;<
. S ALI=$$LRTP(ALI),LRTEXT(ALI)="*** THIS TEST/SPECIMEN WAS NOT SENT TO NTRT ***"
. S A="" S:LRNOS1=1 A="Missing Send Method" S A=A_$S((LRNOS2=1&(A'="")):" and ",1:""),A=A_$S(LRNOS2=1:"Facility is Either Not Production or Not a VA Site",1:"")
. S ALI=$$LRTP(ALI),LRTEXT(ALI)=A
. S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="A new Laboratory Test has been entered at: "_LRSITEN
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Facility Name/Number: "_LRSITEN_" / "_LRSITE
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="For questions or notifications respond to: "_LRGMAIL
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
; S LRTEXT(6)="For NTRT results respond to :"_LRSMAIL
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
I $G(LRRESEND)=1 S ALI=$$LRTP(ALI),LRTEXT(ALI)=" **** THIS TEST/SPECIMEN IS BEING RESENT ****"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="New Laboratory Test Name: "_$G(LXA(.01,"I"))
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="New Laboratory Test LOCAL IEN: "_(+LR60IEN)
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Laboratory Test Site/Specimen Number (IEN): "_$G(LXC(.01,"I"))
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Laboratory Test Site/Specimen Name: "_$G(LXC(.01,"E"))
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S B="",A=$G(LXC(.01,"I")) I A S A=$G(^LAB(61,A,0)),B=$P(A,U,10) I +B>0 S B=$P($G(^LAB(64.061,B,0)),U,1)
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Spec: "_$P(A,U,1)
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Time Aspect: "_B
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Units: "_$G(LXC(6,"I"))
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="RNLT: "_LRNLT
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Lab Section: "_LRSEC
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Subscript: "_$G(LXA(4,"I"))
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Data Name: "_LRDTNM
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Data Comment: "_LRCOM
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Data Type: "_LRCTY
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Reference Low: "_$G(LXC(1,"I"))
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Reference High: "_$G(LXC(2,"I"))
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Therapeutic Low: "_$G(LXC(9.2,"I"))
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Therapeutic High: "_$G(LXC(9.3,"I"))
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
; S A=$G(LXC(13,"I")),B=$S(A=1:"YES",1:"NO")
; S ALI=$$LRTP(ALI),LRTEXT(ALI)="Use Ref Lab: "_B
; S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Test Synonyms: "_LXG
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
; F I=10:2:44 S LRTEXT(I)=""
S E=0 F I=1:1 S E=$O(LXE(E)) Q:'E S G=LXE(E),ALI=$$LRTP(ALI),LRTEXT(ALI)=$S(I=1:"Specimen Interpretation: ",1:" ")_G
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
;START OF CHANGE FOR LR*5.2*500
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Test Creation Date: "_$G(LXA(131,"E"))
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Specimen Create Date: "_$G(LXC(35,"E"))
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="In-House Test: "_$G(LXA(134,"E"))
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="POC Test: "_$G(LXA(135,"E"))
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Scanned Image Test: "_$G(LXA(137,"E"))
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S E=0 F I=0:1 S E=$O(LXH(E)) Q:'E&I D Q:'E
. S ALI=$$LRTP(ALI),LRTEXT(ALI)="Performing Lab: "_$G(LXH(+E,.01))
. S ALI=$$LRTP(ALI),LRTEXT(ALI)=" Order Code: "_$G(LXH(+E,1))
. S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
S ALI=$$LRTP(ALI),LRTEXT(ALI)="Site Notes:"
N STNTDT S STNTDT=9999999 F S STNTDT=$O(^LAB(60,LR60IEN,11,"B",STNTDT),-1) Q:'STNTDT D
. N STNTIEN,I
. S ALI=$$LRTP(ALI),LRTEXT(ALI)="Site Notes Date: "_$$FMTE^XLFDT(STNTDT)
. S STNTIEN=0 S STNTIEN=$O(^LAB(60,+LR60IEN,11,"B",STNTDT,STNTIEN)) Q:'STNTIEN D S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
. . S I=0 F S I=$O(^LAB(60,+LR60IEN,11,STNTIEN,1,I)) Q:'I D
. . . S ALI=$$LRTP(ALI),LRTEXT(ALI)=$G(^LAB(60,+LR60IEN,11,STNTIEN,1,I,0))
S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
;END OF CHANGE FOR LR*5.2*500
S XMTEXT="LRTEXT(" D ^XMD
;
Q
;
CTCHK(LR60IEN) ; check if the test is valid for create date and it hasn't been set previously
; is the test valid for update
N A,B,C,LSITE,LRNT
S A=$$GET1^DIQ(60,LR60IEN_",",131)
I A'="" Q 0
S LSITE=$$SITE^VASITE,LSITE=$P(LSITE,U,1)
S LRNT=$O(^LAB(66.4,"B",LSITE,0))
I +LRNT<1 Q 0
S A=$$GET1^DIQ(66.4,LRNT_",",.06)
I A&(A>(LR60IEN-1)) Q 0
Q 1
;
NSP(LR6001IEN,LR60IEN) ; entry to set specimen date if new specimen
N ZTDTH,ZTRTN,ZTSAVE,ZTIO,ZTSK,ZTDESC,LRN,LRO
; X1-old array X2-new array
M LRO=X1,LRN=X2
S ZTDTH=$$NOW^XLFDT,ZTDESC="LAB Edit Save from file 60 Cross Reference #490"
S ZTRTN="NSPA^LRMLED("_LR6001IEN_","_LR60IEN_")",ZTSAVE("LR60IEN")="",ZTSAVE("LR6001IEN")=""
S ZTSAVE("LRN(")="",ZTSAVE("LRO(")=""
S ZTIO=""
D ^%ZTLOAD
Q
;
NSPA(LRDA,LRDA1) ; save specimen create date if new specimen for test
; (1)-.01 SITE/SPECIMEN
; LRDA - specimen IEN
; LRDA1 - test IEN
; LRO-old array LRN-new array
Q:$D(LRMLTFREC)
N A,B,C,D,E,F,DA
N DR,DIE,DIC,X
I $G(LRO(1))'=""!($G(LRN(1))="") G NSPQ
S DA=LRDA,DA(1)=LRDA1
S A=$$GET1^DIQ(60.01,DA_","_DA(1),35,"I")
I A'="" G NSPQ
I $G(DT)="" S DT=$$DT^XLFDT
S DIE="^LAB(60,"_DA(1)_",1,",DR="35///"_DT
D ^DIE
G NSPQ
;
NSPQ ; quit
K A,B,C,D,E,F,DA,DR,DIE,DIC,X
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
TDT ;place creation date in test
I $G(LXA(131,"I"))'="" Q ; date already on file
S A=$G(LRNTI(".06","I")) I A&(A>(LR60IEN-1)) Q ; only set if test added after patch 468 load
N DA,DR,DIE
L +^LAB(60,LR60IEN):30 I '$T Q
S DA=+LR60IEN,DR="131///"_DT,DIE="^LAB(60," D ^DIE
L -^LAB(60,LR60IEN)
Q
;
SDT ; place specimen creation dt
I $G(LXC(35,"I"))'="" Q ; date on file
N DA,DR,DIE
L +^LAB(60,LR60IEN,1,LRS):30 I '$T Q
S DA(1)=+LR60IEN,DA=LRS,DR="35///"_DT,DIE="^LAB(60,"_DA(1)_",1," D ^DIE
L -^LAB(60,LR60IEN,1,LRS)
Q
;
LRTEXT(AL) ; update counter for message xml
S AL=AL+1
Q AL
;
HL7 ;send hl7 to NTRT
; currently not implemented
Q
;
LRTP(AA) ;update text counter
S AA=AA+1
Q AA
;
XML ;send xml to NTRT
; moved to LRMLEDA for size
D XML^LRMLEDA
Q
;
;
ETSTTYP(LRX) ; get test data type
N LRSTUB,LRTYPE,LRY,K,KK
I LRX="" Q ""
S K="^"_LRX_"0)",KK=$G(@K),$P(LRSTUB,"|",3)=$P(KK,U,1)
S LRX=$P(LRX,"(",2)
;
; Data type
S LRTYPE=$$GET1^DID($P(LRX,","),$P(LRX,",",2,99),"","TYPE")
S $P(LRSTUB,"|",2)=LRTYPE
;
; Input transform
S LRY=$$GET1^DID($P(LRX,","),$P(LRX,",",2,99),"",$S(LRTYPE="SET":"POINTER",1:"INPUT TRANSFORM"))
I LRTYPE="NUMERIC",LRY["LRNUM" D
. S LRX=$P(LRY,"""",2)
. I LRX?.1"-".N1","1.N1","1N S LRY="Number from "_$P(LRX,",")_" to "_$P(LRX,",",2)_" with "_$P(LRX,",",3)_" decimal"
. S $P(LRSTUB,"|",1)=LRY
; Help prompt
I LRTYPE="FREE TEXT" D
. S LRY=$$GET1^DID($P(LRX,","),$P(LRX,",",2,99),"","HELP-PROMPT")
. S $P(LRSTUB,"|",1)=LRY
Q LRSTUB
;
EOUT ; quit
L -^TMP(LR60IEN,LRS)
K LXA,LXB,LXC,LXD,LXE,LXF,LXG,LXH,A,LR60IEN,DA,DIC,DIQ,B,C,D,LRS,LSITE,LRNT,LRNTI,AR,I,LRMLTFREC
K LRSITE,LRSITEN,LRGMAIL,LRSMAIL,LRNMAIL,LACT,MAILPERSON,LR64,LRNLT,LRSEC,LRCOM,LRCTY,LRNEWTEST,LRSUBSCRIPT
K LRNOS1,LRNOS2,LRSCHPA,LRSCHNM,ALI,LRTEXT,LR64N,LRDTNM,G
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
; This section is called by the NEW Record cross references in file 60
; CR 489 for BED (base level edit) and SITE/SPECIMEN sub Level 490 for SED
;
BED(LR60IEN) ;ENTRY POINT FOR MAIN EDITS
;
N ZTDTH,ZTRTN,ZTSAVE,ZTIO,ZTSK,ZTDESC,LRN,LRO
M LRO=X1,LRN=X2
S ZTDTH=$$NOW^XLFDT,ZTDESC="LAB Edit Save from file 60 Cross Reference #489"
S ZTRTN="BEDA^LRMLED("_LR60IEN_")",ZTSAVE("LR60IEN")=""
S ZTSAVE("LRN(")="",ZTSAVE("LRO(")=""
S ZTIO=""
D ^%ZTLOAD
Q
;
BEDA(LRDA) ; edits from main level
Q:$D(LRMLTFREC)
; (1)-3 TYPE (2)-131 CREATION DATE (3)-133 TEST INACTIVE DATE
; X1-old array X2-new array
N A,B,C,D,E,F,G,I,DA,LO,LN,LE,LLI,LTYP
M A=DR S D=0
N DR,DIE,DIC,X
F I=1:1:3 S F=$G(LRO(I)),G=$G(LRN(I)) I F'=G S D=1
I 'D G BEDO
F LLI=1:1:3 S LO=$G(LRO(LLI)),LN=$G(LRN(LLI)) I LO'=LN S LTYP=$S(LLI=1:"Y",LLI=2:"C",1:"T") D D SAV
. ; I LTYP="C"!(LTYP="T") S:+LO>0 LO=$$FMTE^XLFDT(LO,9) S:+LN>0 LN=$$FMTE^XLFDT(LN,9)
G BEDO
;
BEDO K A,B,C,D,E,I,X,DA,LRN,LRO,LO,LN,LE,LLI,DR,DIE,DIC,LRMLTFREC,LTYP
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
SAV ; file edit in 60.28
N DR,DIE,DIC,X,DA,Y,LRMLTFREC,LE
S DA(1)=LRDA,DA=0,LRMLTFREC=1
S LE="^LAB(60,"_DA(1)_",15,",DIC=LE,DIC(0)="QEAL"
S X=$$NOW^XLFDT
L +^LAB(60,DA(1),15):30 I '$T Q
D FILE^DICN
L -^LAB(60,DA(1),15)
I Y="-1" Q
S DIE=LE,DA=+Y
S DR=".02///"_+$G(DUZ)_";.03///"_LTYP_";.04///"_LO_";.05///"_LN
D ^DIE
K DR,DIE,DIC,X,DA,Y,LRMLTFREC,LE
Q
;
SED(LR6001IEN,LR60IEN) ;ENTRY POINT FOR MAIN SITE/SPECIMEN EDITS
;
N ZTDTH,ZTRTN,ZTSAVE,ZTIO,ZTSK,ZTDESC,LRN,LRO
M LRO=X1,LRN=X2
S ZTDTH=$$NOW^XLFDT,ZTDESC="LAB Edit Save from file 60 Cross Reference #490"
S ZTRTN="SEDA^LRMLED("_LR6001IEN_","_LR60IEN_")",ZTSAVE("LR60IEN")="",ZTSAVE("LR6001IEN")=""
S ZTSAVE("LRN(")="",ZTSAVE("LRO(")=""
S ZTIO=""
D ^%ZTLOAD
Q
;
SEDA(LRDA,LRDA1) ; edits from site/specimen level
; (1)-30 MLTF VUID (2)-RESULT/SPECIMEN INACTIVE DATE (3)-EXCEPTION FLAG (4)-SPECIMEN CREATE DATE
; X1-old array X2-new array
Q:$D(LRMLTFREC)
N A,B,C,D,E,F,DA,LLI,LTYP
M A=DR
N DR,DIE,DIC,X
S D="" F I=1:1:4 S E=$G(LRO(I)),F=$G(LRN(I)) I E'=F S D=1
I 'D G BEDO
F LLI=1:1:4 S LO=$G(LRO(LLI)),LN=$G(LRN(LLI)) I LO'=LN S LTYP=$S(LLI=1:"M",LLI=2:"R",LLI=3:"E",1:"S") D D SSAV
. ; I LTYP="R"!(LTYP="S") S:+LO>0 LO=$$FMTE^XLFDT(LO,9) S:+LN>0 LN=$$FMTE^XLFDT(LN,9)
G BEDO
Q
;
SSAV ; file edit in 60.28
N DR,DIE,DIC,X,DA,Y,LRMLTFREC,LE
S DA(1)=LRDA1,DA=0,LRMLTFREC=1
S LE="^LAB(60,"_DA(1)_",15,",DIC=LE,DIC(0)="QEAL"
S X=$$NOW^XLFDT
L +^LAB(60,DA(1),15):30 I '$T Q
D FILE^DICN
L -^LAB(60,DA(1),15)
I Y="-1" Q
S DIE=LE,DA=+Y
S DR=".02///"_+$G(DUZ)_";.03///"_LTYP_";.04///"_LO_";.05///"_LN_";.06///"_LRDA
D ^DIE
K DR,DIE,DIC,X,DA,Y,LRMLTFREC,LE
Q
;
GET664 ; get file 66.4 info
S LSITE=$$SITE^VASITE,LSITE=$P(LSITE,U,1)
S LRNT=$O(^LAB(66.4,"B",LSITE,0))
D GETS^DIQ(66.4,LRNT_",","**","IE","AR")
M LRNTI=AR("66.4",LRNT_",") K AR
Q
;
GET60T ; get top of file 60 test info
S DIQ="LXB",DIQ(0)="IE",DIC=60,DR=".01;131" K ^UTILITY("DIQ1",$J) D EN^DIQ1 K ^UTILITY("DIQ1",$J)
K LXA M LXA=LXB(60,DA) K LXB
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMLED 16837 printed Sep 23, 2025@19:53:36 Page 2
LRMLED ;BPFO/DTG - NTRT MESSAGE PROCESS AND EDITS UPDATE ;12/26/2016
+1 ;;5.2;LAB SERVICE;**468,500,517**;Sep 27, 1994;Build 5
+2 ;
+3 ; ESTART is called from a 'NEW' format cross reference on the 60 file AMLTFNTRT
+4 ; and will send NTRT message if appropiate.
EN(LRS,LR60IEN) ; entry point from cross reference
+1 ; only have one
+2 LOCK +^TMP(LR60IEN,LRS):1
IF '$TEST
QUIT
+3 NEW ZTDTH,ZTRTN,ZTSAVE,ZTIO,ZTSK,ZTDESC
+4 ; START OF CHANGE FOR LR*5.2*500
+5 ;S ZTDTH=$$NOW^XLFDT,ZTDESC="LAB Create NTRT message from file 60 Cross Reference #491"
+6 SET B=$HOROLOG
SET A=$$HADD^XLFDT(B,,8,,)
SET C=$$HTFM^XLFDT(A)
+7 SET ZTDTH=C
SET ZTDESC="LAB Create NTRT message from file 60 Cross Reference #491"
+8 SET ZTRTN="ESTART^LRMLED("_LR60IEN_","_LRS_")"
SET ZTSAVE("LR60IEN")=""
SET ZTSAVE("LRS")=""
SET ZTIO=""
SET ZTSAVE("LRDUZ")=DUZ
+9 DO ^%ZTLOAD
+10 LOCK -^TMP(LR60IEN,LRS)
+11 QUIT
+12 ;
ESTART(LR60IEN,LRS) ; pick up key data for NTRT
+1 if $DATA(LRMLTFREC)
QUIT
+2 LOCK +^TMP(LR60IEN,LRS):30
IF '$TEST
QUIT
+3 ;START OF CHANGE FOR LR*5.2*500
+4 NEW LXA,LXB,LXC,LXG,LXD,LXE,LXF,LXH,A,B,C,D,LSITE,LRNT,LRNTI,AR,LRNLT,LRSEC,I,LRNOS1,LRNOS2
+5 ;END OF CHANGE FOR LR*5.2*500
+6 NEW LRSITE,LRSITEN,LRGMAIL,LRSMAIL,LRNAMIL,LACT,MAILPERSON,LR64,LRCOM,LRCTY,LRSUBSCRIPT
+7 NEW LRSCHPA,LRSCHNM,ALI,LRTEXT,LR64N,LRDTNM,G
+8 if $GET(LRDUZ)=""
SET LRDUZ=$GET(DUZ)
+9 IF $GET(DT)=""
SET DT=$$DT^XLFDT
+10 DO GET664
+11 ; check if allow to send to NTRT
+12 ; I $G(LRNTI(.1,"I"))'=1 G EOUT
+13 ;
+14 ;site number and name
+15 SET LRSITE=$GET(LRNTI(.01,"I"))
SET LRSITEN=$GET(LRNTI(.01,"E"))
+16 ;ntrt mail group
+17 SET LRNMAIL=$GET(LRNTI(1,"I"))
+18 ;lab send mail group
+19 SET LRGMAIL=$GET(LRNTI(2,"I"))
+20 ;lab server side mail group
+21 SET LRSMAIL=$GET(LRNTI(3,"I"))
+22 ;how to send mail
+23 SET LACT=$GET(LRNTI(.02,"E"))
+24 ; get type of test to send
+25 ; default to CH only
SET LRSUBSCRIPT=$GET(LRNTI(.07,"I"))
IF LRSUBSCRIPT=""
SET LRSUBSCRIPT=1
+26 ; send blood bank?
+27 ;
+28 SET DA=+LR60IEN
+29 ;get test
EA ; .01 test name, 4 subscript (CH), 5 data name, 13 field (DD of 5), 64.1 result nlt code
+1 SET DIQ="LXB"
SET DIQ(0)="IE"
SET DIC=60
SET DR=".01;4;64.1;5;13;131;132;133;134;135;137"
KILL ^UTILITY("DIQ1",$JOB)
DO EN^DIQ1
KILL ^UTILITY("DIQ1",$JOB)
+2 KILL LXA
MERGE LXA=LXB(60,DA)
KILL LXB
+3 DO TDT
+4 ; check test subscript is valid for NTRT
+5 SET A=$GET(LXA(4,"I"))
+6 ; don't send if workload
IF A="WK"
GOTO EOUT
+7 IF A="AU"
GOTO EOUT
+8 IF A="EM"
GOTO EOUT
+9 IF A="BB"
GOTO EOUT
+10 IF A="CH"&((LRSUBSCRIPT=1)!(LRSUBSCRIPT=7)!(LRSUBSCRIPT=8))
GOTO EGOOD
+11 IF A="MI"&((LRSUBSCRIPT=2)!(LRSUBSCRIPT=7)!(LRSUBSCRIPT=8))
GOTO EGOOD
+12 ; I A="EM"&((LRSUBSCRIPT=3)!(LRSUBSCRIPT=8)) G EGOOD ; do not do AU per Leeanne 6/2016
+13 IF A="SP"&((LRSUBSCRIPT=4)!(LRSUBSCRIPT=8))
GOTO EGOOD
+14 IF A="CY"&((LRSUBSCRIPT=5)!(LRSUBSCRIPT=8))
GOTO EGOOD
+15 ; I A="AU"&((LRSUBSCRIPT=6)!(LRSUBSCRIPT=8)) G EGOOD ; do not do AU per Leeanne 6/2016
+16 ; doesn't match up
GOTO EOUT
+17 ;
EGOOD ; if the subscript is valid
+1 ; check if inactive
+2 SET A=$GET(LXA(132,"I"))
SET B=$GET(LXA(133,"I"))
IF A'=""!(B'="")
GOTO EOUT
+3 ;get synonyms
+4 KILL B
SET LXG=""
SET A=0
FOR I=0:1
SET A=$ORDER(^LAB(60,DA,5,A))
if 'A
QUIT
SET B(I)=$PIECE(^LAB(60,DA,5,A,0),U,1)
+5 IF I>0
SET B=I-1
FOR I=0:1:B
Begin DoDot:1
+6 IF LXG=""
SET LXG=B(I)
QUIT
+7 SET LXG=LXG_U_B(I)
End DoDot:1
IF $LENGTH(LXG)>210
QUIT
+8 ;get nlt number
+9 SET LR64=$GET(LXA(64.1,"I"))
SET (LRNLT,LRSEC)=""
SET LR64N=$GET(LXA(64.1,"E"))
+10 IF LR64'=""
SET LRNLT=$GET(^LAM(LR64,0))
SET A=$PIECE(LRNLT,U,15)
SET LRNLT=$PIECE(LRNLT,U,2)
+11 IF A'=""
SET LRSEC=$PIECE($GET(^LAB(64.21,A,0)),U,2)
+12 ;get comment / data type from comment
+13 SET (LRCOM,LRCTY,LRDTNM)=""
SET A=$GET(LXA(13,"I"))
SET LRDTNM=$PIECE($GET(LXA(5,"I")),";",2)
+14 IF A'=""
SET B=$$ETSTTYP(A)
SET LRCOM=$PIECE(B,"|",1)
SET LRCTY=$PIECE(B,"|",2)
if $PIECE(B,"|",3)'=""
SET LRDTNM=LRDTNM_" - "_$PIECE(B,"|",3)
+15 ;START OF CHANGE FOR LR*5.2*500
+16 ; get the performing labs
+17 DO LIST^DIC(60.16,","_DA_",","@;.01;1","",,,,,,,"LXB")
+18 KILL LXH
MERGE LXH=LXB("DILIST","ID")
KILL LXB
+19 ;END OF CHANGE FOR LR*5.2*500
+20 ; get specimen info
ES ; LRS is passed in and is the specimen IEN
+1 SET DIQ="LXB"
SET DIQ(0)="IE"
SET DIC=60
SET DR=100
SET DA=+LR60IEN
KILL LXB,^UTILITY("DIQ1",$JOB)
+2 SET DR(60.01)=".01;6;1;2;9.2;9.3;13;30;32;33;34;35"
SET DA(60.01)=LRS
+3 DO EN^DIQ1
KILL ^UTILITY("DIQ1",$JOB)
+4 KILL LXC
MERGE LXC=LXB("60.01",LRS)
KILL LXB
+5 ; get the specimen INTERPRETATION
+6 DO GETS^DIQ(60.01,LRS_","_DA,"5.5","","LXB")
+7 KILL LXE
MERGE LXE=LXB(60.01,LRS_","_DA_",",5.5)
KILL LXB
+8 ; don't do if MLTF already associated
+9 IF $GET(LXC(30,"I"))'=""
GOTO EOUT
+10 ; don't do if inactive or already sent
+11 SET A=$GET(LXC(32,"I"))
SET B=$GET(LXC(33,"I"))
SET C=$GET(LXC(34,"I"))
IF $EXTRACT(A,1)="Y"!(B'="")!($EXTRACT(C,1)="Y")
GOTO EOUT
+12 ;if no send method or not allowed to send to NTRT
+13 ;START OF CHANGE FOR LR*5.2*500
+14 SET LRNOS1=0
IF LACT=""!($GET(LRNTI(.02,"I"))="N")!($GET(LRNTI(.1,"I"))'=1)
SET LRNOS1=1
+15 ;END OF CHANGE FOR LR*5.2*500
+16 SET A=$TRANSLATE(LRGMAIL,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+17 SET LRNOS2=0
IF '$$PROD^XUPROD()!(LRGMAIL'["DOMAIN.EXT")
SET LRNOS2=1
+18 IF LACT=""!($EXTRACT(LACT,1)="N")
DO MAILMAN
GOTO EOUT
+19 DO @LACT
+20 ;put exception flag in 60 file
+21 ; since making exception flag uneditable must do physical set
+22 ;START OF CHANGE FOR LR*5.2*500
+23 ;I (LRNOS1'=1&(LRNOS2'=1)) D ;<
+24 ; p517 exit if missing 0 node rec for SITE/SPECIMEN
if '$GET(^LAB(60,LR60IEN,1,LRS,0))
GOTO EOUT
+25 NEW A,B,LRO,LRN,I
SET A=$GET(^LAB(60,LR60IEN,1,LRS,5))
SET B=A
SET $PIECE(B,U,3)="Y"
SET ^LAB(60,LR60IEN,1,LRS,5)=B
+26 ; need to build array for saving in audit section
+27 FOR I=1,2,4
SET LRO(I)=""
SET LRN(I)=""
+28 SET LRO(3)=$PIECE(A,U,3)
SET LRN(3)=$PIECE(B,U,3)
+29 NEW ZTDTH,ZTRTN,ZTSAVE,ZTIO,ZTSK,ZTDESC
+30 SET ZTDTH=$$NOW^XLFDT
SET ZTDESC="LAB Edit Save of Deployed Flag"
+31 SET ZTRTN="SEDA^LRMLED("_LRS_","_LR60IEN_")"
SET ZTSAVE("LR60IEN")=""
SET ZTSAVE("LRS")=""
+32 SET ZTSAVE("LRN(")=""
SET ZTSAVE("LRO(")=""
+33 SET ZTIO=""
+34 DO ^%ZTLOAD
+35 ;END OF CHANGE FOR LR*5.2*500
+36 GOTO EOUT
+37 ;
MAILMAN ;mailman
+1 NEW XMSUB,XMY,XMTEXT,LRTEXT,XMDUZ,DA,DR,DIE
+2 ;
+3 ; missing NTRT recipient
IF LRNMAIL=""
QUIT
+4 ;
+5 SET XMSUB="NEW NTRT REQUEST FOR LABORATORY"
+6 ;S XMY(DUZ)=""
+7 SET XMY(LRDUZ)=""
+8 ; send to NTRT if ntrt mail group and send method and production/va site
+9 IF LRNMAIL'=""
SET XMY(LRNMAIL)=""
IF LRNOS1=1!(LRNOS2=1)
KILL XMY(LRNMAIL)
+10 ;
+11 IF LRGMAIL'=""
SET XMDUZ("New Test/Specimen NTRT Request From: "_$EXTRACT(LRSITEN,1,30))=""
SET XMY($PIECE(LRGMAIL,"@",1))=""
+12 SET ALI=0
+13 ;<
IF LRNOS1=1!(LRNOS2=1)
Begin DoDot:1
+14 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="*** THIS TEST/SPECIMEN WAS NOT SENT TO NTRT ***"
+15 SET A=""
if LRNOS1=1
SET A="Missing Send Method"
SET A=A_$SELECT((LRNOS2=1&(A'="")):" and ",1:"")
SET A=A_$SELECT(LRNOS2=1:"Facility is Either Not Production or Not a VA Site",1:"")
+16 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=A
+17 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
End DoDot:1
+18 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="A new Laboratory Test has been entered at: "_LRSITEN
+19 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+20 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Facility Name/Number: "_LRSITEN_" / "_LRSITE
+21 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+22 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="For questions or notifications respond to: "_LRGMAIL
+23 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+24 ; S LRTEXT(6)="For NTRT results respond to :"_LRSMAIL
+25 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+26 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+27 IF $GET(LRRESEND)=1
SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=" **** THIS TEST/SPECIMEN IS BEING RESENT ****"
+28 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="New Laboratory Test Name: "_$GET(LXA(.01,"I"))
+29 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+30 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="New Laboratory Test LOCAL IEN: "_(+LR60IEN)
+31 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+32 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Laboratory Test Site/Specimen Number (IEN): "_$GET(LXC(.01,"I"))
+33 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+34 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Laboratory Test Site/Specimen Name: "_$GET(LXC(.01,"E"))
+35 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+36 SET B=""
SET A=$GET(LXC(.01,"I"))
IF A
SET A=$GET(^LAB(61,A,0))
SET B=$PIECE(A,U,10)
IF +B>0
SET B=$PIECE($GET(^LAB(64.061,B,0)),U,1)
+37 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+38 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Spec: "_$PIECE(A,U,1)
+39 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+40 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Time Aspect: "_B
+41 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+42 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Units: "_$GET(LXC(6,"I"))
+43 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+44 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="RNLT: "_LRNLT
+45 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+46 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Lab Section: "_LRSEC
+47 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+48 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Subscript: "_$GET(LXA(4,"I"))
+49 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+50 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Data Name: "_LRDTNM
+51 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+52 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Data Comment: "_LRCOM
+53 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+54 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Data Type: "_LRCTY
+55 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+56 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Reference Low: "_$GET(LXC(1,"I"))
+57 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+58 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Reference High: "_$GET(LXC(2,"I"))
+59 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+60 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Therapeutic Low: "_$GET(LXC(9.2,"I"))
+61 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+62 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Therapeutic High: "_$GET(LXC(9.3,"I"))
+63 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+64 ; S A=$G(LXC(13,"I")),B=$S(A=1:"YES",1:"NO")
+65 ; S ALI=$$LRTP(ALI),LRTEXT(ALI)="Use Ref Lab: "_B
+66 ; S ALI=$$LRTP(ALI),LRTEXT(ALI)=""
+67 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Test Synonyms: "_LXG
+68 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+69 ; F I=10:2:44 S LRTEXT(I)=""
+70 SET E=0
FOR I=1:1
SET E=$ORDER(LXE(E))
if 'E
QUIT
SET G=LXE(E)
SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=$SELECT(I=1:"Specimen Interpretation: ",1:" ")_G
+71 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+72 ;START OF CHANGE FOR LR*5.2*500
+73 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Test Creation Date: "_$GET(LXA(131,"E"))
+74 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+75 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Specimen Create Date: "_$GET(LXC(35,"E"))
+76 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+77 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="In-House Test: "_$GET(LXA(134,"E"))
+78 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+79 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="POC Test: "_$GET(LXA(135,"E"))
+80 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+81 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Scanned Image Test: "_$GET(LXA(137,"E"))
+82 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+83 SET E=0
FOR I=0:1
SET E=$ORDER(LXH(E))
if 'E&I
QUIT
Begin DoDot:1
+84 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Performing Lab: "_$GET(LXH(+E,.01))
+85 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=" Order Code: "_$GET(LXH(+E,1))
+86 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
End DoDot:1
if 'E
QUIT
+87 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Site Notes:"
+88 NEW STNTDT
SET STNTDT=9999999
FOR
SET STNTDT=$ORDER(^LAB(60,LR60IEN,11,"B",STNTDT),-1)
if 'STNTDT
QUIT
Begin DoDot:1
+89 NEW STNTIEN,I
+90 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="Site Notes Date: "_$$FMTE^XLFDT(STNTDT)
+91 SET STNTIEN=0
SET STNTIEN=$ORDER(^LAB(60,+LR60IEN,11,"B",STNTDT,STNTIEN))
if 'STNTIEN
QUIT
Begin DoDot:2
+92 SET I=0
FOR
SET I=$ORDER(^LAB(60,+LR60IEN,11,STNTIEN,1,I))
if 'I
QUIT
Begin DoDot:3
+93 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=$GET(^LAB(60,+LR60IEN,11,STNTIEN,1,I,0))
End DoDot:3
End DoDot:2
SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
End DoDot:1
+94 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=""
+95 ;END OF CHANGE FOR LR*5.2*500
+96 SET XMTEXT="LRTEXT("
DO ^XMD
+97 ;
+98 QUIT
+99 ;
CTCHK(LR60IEN) ; check if the test is valid for create date and it hasn't been set previously
+1 ; is the test valid for update
+2 NEW A,B,C,LSITE,LRNT
+3 SET A=$$GET1^DIQ(60,LR60IEN_",",131)
+4 IF A'=""
QUIT 0
+5 SET LSITE=$$SITE^VASITE
SET LSITE=$PIECE(LSITE,U,1)
+6 SET LRNT=$ORDER(^LAB(66.4,"B",LSITE,0))
+7 IF +LRNT<1
QUIT 0
+8 SET A=$$GET1^DIQ(66.4,LRNT_",",.06)
+9 IF A&(A>(LR60IEN-1))
QUIT 0
+10 QUIT 1
+11 ;
NSP(LR6001IEN,LR60IEN) ; entry to set specimen date if new specimen
+1 NEW ZTDTH,ZTRTN,ZTSAVE,ZTIO,ZTSK,ZTDESC,LRN,LRO
+2 ; X1-old array X2-new array
+3 MERGE LRO=X1,LRN=X2
+4 SET ZTDTH=$$NOW^XLFDT
SET ZTDESC="LAB Edit Save from file 60 Cross Reference #490"
+5 SET ZTRTN="NSPA^LRMLED("_LR6001IEN_","_LR60IEN_")"
SET ZTSAVE("LR60IEN")=""
SET ZTSAVE("LR6001IEN")=""
+6 SET ZTSAVE("LRN(")=""
SET ZTSAVE("LRO(")=""
+7 SET ZTIO=""
+8 DO ^%ZTLOAD
+9 QUIT
+10 ;
NSPA(LRDA,LRDA1) ; save specimen create date if new specimen for test
+1 ; (1)-.01 SITE/SPECIMEN
+2 ; LRDA - specimen IEN
+3 ; LRDA1 - test IEN
+4 ; LRO-old array LRN-new array
+5 if $DATA(LRMLTFREC)
QUIT
+6 NEW A,B,C,D,E,F,DA
+7 NEW DR,DIE,DIC,X
+8 IF $GET(LRO(1))'=""!($GET(LRN(1))="")
GOTO NSPQ
+9 SET DA=LRDA
SET DA(1)=LRDA1
+10 SET A=$$GET1^DIQ(60.01,DA_","_DA(1),35,"I")
+11 IF A'=""
GOTO NSPQ
+12 IF $GET(DT)=""
SET DT=$$DT^XLFDT
+13 SET DIE="^LAB(60,"_DA(1)_",1,"
SET DR="35///"_DT
+14 DO ^DIE
+15 GOTO NSPQ
+16 ;
NSPQ ; quit
+1 KILL A,B,C,D,E,F,DA,DR,DIE,DIC,X
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 QUIT
+4 ;
TDT ;place creation date in test
+1 ; date already on file
IF $GET(LXA(131,"I"))'=""
QUIT
+2 ; only set if test added after patch 468 load
SET A=$GET(LRNTI(".06","I"))
IF A&(A>(LR60IEN-1))
QUIT
+3 NEW DA,DR,DIE
+4 LOCK +^LAB(60,LR60IEN):30
IF '$TEST
QUIT
+5 SET DA=+LR60IEN
SET DR="131///"_DT
SET DIE="^LAB(60,"
DO ^DIE
+6 LOCK -^LAB(60,LR60IEN)
+7 QUIT
+8 ;
SDT ; place specimen creation dt
+1 ; date on file
IF $GET(LXC(35,"I"))'=""
QUIT
+2 NEW DA,DR,DIE
+3 LOCK +^LAB(60,LR60IEN,1,LRS):30
IF '$TEST
QUIT
+4 SET DA(1)=+LR60IEN
SET DA=LRS
SET DR="35///"_DT
SET DIE="^LAB(60,"_DA(1)_",1,"
DO ^DIE
+5 LOCK -^LAB(60,LR60IEN,1,LRS)
+6 QUIT
+7 ;
LRTEXT(AL) ; update counter for message xml
+1 SET AL=AL+1
+2 QUIT AL
+3 ;
HL7 ;send hl7 to NTRT
+1 ; currently not implemented
+2 QUIT
+3 ;
LRTP(AA) ;update text counter
+1 SET AA=AA+1
+2 QUIT AA
+3 ;
XML ;send xml to NTRT
+1 ; moved to LRMLEDA for size
+2 DO XML^LRMLEDA
+3 QUIT
+4 ;
+5 ;
ETSTTYP(LRX) ; get test data type
+1 NEW LRSTUB,LRTYPE,LRY,K,KK
+2 IF LRX=""
QUIT ""
+3 SET K="^"_LRX_"0)"
SET KK=$GET(@K)
SET $PIECE(LRSTUB,"|",3)=$PIECE(KK,U,1)
+4 SET LRX=$PIECE(LRX,"(",2)
+5 ;
+6 ; Data type
+7 SET LRTYPE=$$GET1^DID($PIECE(LRX,","),$PIECE(LRX,",",2,99),"","TYPE")
+8 SET $PIECE(LRSTUB,"|",2)=LRTYPE
+9 ;
+10 ; Input transform
+11 SET LRY=$$GET1^DID($PIECE(LRX,","),$PIECE(LRX,",",2,99),"",$SELECT(LRTYPE="SET":"POINTER",1:"INPUT TRANSFORM"))
+12 IF LRTYPE="NUMERIC"
IF LRY["LRNUM"
Begin DoDot:1
+13 SET LRX=$PIECE(LRY,"""",2)
+14 IF LRX?.1"-".N1","1.N1","1N
SET LRY="Number from "_$PIECE(LRX,",")_" to "_$PIECE(LRX,",",2)_" with "_$PIECE(LRX,",",3)_" decimal"
+15 SET $PIECE(LRSTUB,"|",1)=LRY
End DoDot:1
+16 ; Help prompt
+17 IF LRTYPE="FREE TEXT"
Begin DoDot:1
+18 SET LRY=$$GET1^DID($PIECE(LRX,","),$PIECE(LRX,",",2,99),"","HELP-PROMPT")
+19 SET $PIECE(LRSTUB,"|",1)=LRY
End DoDot:1
+20 QUIT LRSTUB
+21 ;
EOUT ; quit
+1 LOCK -^TMP(LR60IEN,LRS)
+2 KILL LXA,LXB,LXC,LXD,LXE,LXF,LXG,LXH,A,LR60IEN,DA,DIC,DIQ,B,C,D,LRS,LSITE,LRNT,LRNTI,AR,I,LRMLTFREC
+3 KILL LRSITE,LRSITEN,LRGMAIL,LRSMAIL,LRNMAIL,LACT,MAILPERSON,LR64,LRNLT,LRSEC,LRCOM,LRCTY,LRNEWTEST,LRSUBSCRIPT
+4 KILL LRNOS1,LRNOS2,LRSCHPA,LRSCHNM,ALI,LRTEXT,LR64N,LRDTNM,G
+5 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+6 QUIT
+7 ;
+8 ; This section is called by the NEW Record cross references in file 60
+9 ; CR 489 for BED (base level edit) and SITE/SPECIMEN sub Level 490 for SED
+10 ;
BED(LR60IEN) ;ENTRY POINT FOR MAIN EDITS
+1 ;
+2 NEW ZTDTH,ZTRTN,ZTSAVE,ZTIO,ZTSK,ZTDESC,LRN,LRO
+3 MERGE LRO=X1,LRN=X2
+4 SET ZTDTH=$$NOW^XLFDT
SET ZTDESC="LAB Edit Save from file 60 Cross Reference #489"
+5 SET ZTRTN="BEDA^LRMLED("_LR60IEN_")"
SET ZTSAVE("LR60IEN")=""
+6 SET ZTSAVE("LRN(")=""
SET ZTSAVE("LRO(")=""
+7 SET ZTIO=""
+8 DO ^%ZTLOAD
+9 QUIT
+10 ;
BEDA(LRDA) ; edits from main level
+1 if $DATA(LRMLTFREC)
QUIT
+2 ; (1)-3 TYPE (2)-131 CREATION DATE (3)-133 TEST INACTIVE DATE
+3 ; X1-old array X2-new array
+4 NEW A,B,C,D,E,F,G,I,DA,LO,LN,LE,LLI,LTYP
+5 MERGE A=DR
SET D=0
+6 NEW DR,DIE,DIC,X
+7 FOR I=1:1:3
SET F=$GET(LRO(I))
SET G=$GET(LRN(I))
IF F'=G
SET D=1
+8 IF 'D
GOTO BEDO
+9 FOR LLI=1:1:3
SET LO=$GET(LRO(LLI))
SET LN=$GET(LRN(LLI))
IF LO'=LN
SET LTYP=$SELECT(LLI=1:"Y",LLI=2:"C",1:"T")
Begin DoDot:1
+10 ; I LTYP="C"!(LTYP="T") S:+LO>0 LO=$$FMTE^XLFDT(LO,9) S:+LN>0 LN=$$FMTE^XLFDT(LN,9)
End DoDot:1
DO SAV
+11 GOTO BEDO
+12 ;
BEDO KILL A,B,C,D,E,I,X,DA,LRN,LRO,LO,LN,LE,LLI,DR,DIE,DIC,LRMLTFREC,LTYP
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
+3 ;
SAV ; file edit in 60.28
+1 NEW DR,DIE,DIC,X,DA,Y,LRMLTFREC,LE
+2 SET DA(1)=LRDA
SET DA=0
SET LRMLTFREC=1
+3 SET LE="^LAB(60,"_DA(1)_",15,"
SET DIC=LE
SET DIC(0)="QEAL"
+4 SET X=$$NOW^XLFDT
+5 LOCK +^LAB(60,DA(1),15):30
IF '$TEST
QUIT
+6 DO FILE^DICN
+7 LOCK -^LAB(60,DA(1),15)
+8 IF Y="-1"
QUIT
+9 SET DIE=LE
SET DA=+Y
+10 SET DR=".02///"_+$GET(DUZ)_";.03///"_LTYP_";.04///"_LO_";.05///"_LN
+11 DO ^DIE
+12 KILL DR,DIE,DIC,X,DA,Y,LRMLTFREC,LE
+13 QUIT
+14 ;
SED(LR6001IEN,LR60IEN) ;ENTRY POINT FOR MAIN SITE/SPECIMEN EDITS
+1 ;
+2 NEW ZTDTH,ZTRTN,ZTSAVE,ZTIO,ZTSK,ZTDESC,LRN,LRO
+3 MERGE LRO=X1,LRN=X2
+4 SET ZTDTH=$$NOW^XLFDT
SET ZTDESC="LAB Edit Save from file 60 Cross Reference #490"
+5 SET ZTRTN="SEDA^LRMLED("_LR6001IEN_","_LR60IEN_")"
SET ZTSAVE("LR60IEN")=""
SET ZTSAVE("LR6001IEN")=""
+6 SET ZTSAVE("LRN(")=""
SET ZTSAVE("LRO(")=""
+7 SET ZTIO=""
+8 DO ^%ZTLOAD
+9 QUIT
+10 ;
SEDA(LRDA,LRDA1) ; edits from site/specimen level
+1 ; (1)-30 MLTF VUID (2)-RESULT/SPECIMEN INACTIVE DATE (3)-EXCEPTION FLAG (4)-SPECIMEN CREATE DATE
+2 ; X1-old array X2-new array
+3 if $DATA(LRMLTFREC)
QUIT
+4 NEW A,B,C,D,E,F,DA,LLI,LTYP
+5 MERGE A=DR
+6 NEW DR,DIE,DIC,X
+7 SET D=""
FOR I=1:1:4
SET E=$GET(LRO(I))
SET F=$GET(LRN(I))
IF E'=F
SET D=1
+8 IF 'D
GOTO BEDO
+9 FOR LLI=1:1:4
SET LO=$GET(LRO(LLI))
SET LN=$GET(LRN(LLI))
IF LO'=LN
SET LTYP=$SELECT(LLI=1:"M",LLI=2:"R",LLI=3:"E",1:"S")
Begin DoDot:1
+10 ; I LTYP="R"!(LTYP="S") S:+LO>0 LO=$$FMTE^XLFDT(LO,9) S:+LN>0 LN=$$FMTE^XLFDT(LN,9)
End DoDot:1
DO SSAV
+11 GOTO BEDO
+12 QUIT
+13 ;
SSAV ; file edit in 60.28
+1 NEW DR,DIE,DIC,X,DA,Y,LRMLTFREC,LE
+2 SET DA(1)=LRDA1
SET DA=0
SET LRMLTFREC=1
+3 SET LE="^LAB(60,"_DA(1)_",15,"
SET DIC=LE
SET DIC(0)="QEAL"
+4 SET X=$$NOW^XLFDT
+5 LOCK +^LAB(60,DA(1),15):30
IF '$TEST
QUIT
+6 DO FILE^DICN
+7 LOCK -^LAB(60,DA(1),15)
+8 IF Y="-1"
QUIT
+9 SET DIE=LE
SET DA=+Y
+10 SET DR=".02///"_+$GET(DUZ)_";.03///"_LTYP_";.04///"_LO_";.05///"_LN_";.06///"_LRDA
+11 DO ^DIE
+12 KILL DR,DIE,DIC,X,DA,Y,LRMLTFREC,LE
+13 QUIT
+14 ;
GET664 ; get file 66.4 info
+1 SET LSITE=$$SITE^VASITE
SET LSITE=$PIECE(LSITE,U,1)
+2 SET LRNT=$ORDER(^LAB(66.4,"B",LSITE,0))
+3 DO GETS^DIQ(66.4,LRNT_",","**","IE","AR")
+4 MERGE LRNTI=AR("66.4",LRNT_",")
KILL AR
+5 QUIT
+6 ;
GET60T ; get top of file 60 test info
+1 SET DIQ="LXB"
SET DIQ(0)="IE"
SET DIC=60
SET DR=".01;131"
KILL ^UTILITY("DIQ1",$JOB)
DO EN^DIQ1
KILL ^UTILITY("DIQ1",$JOB)
+2 KILL LXA
MERGE LXA=LXB(60,DA)
KILL LXB
+3 QUIT
+4 ;
