LRMLEDA ;BPFO/DTG - NTRT MESSAGE PROCESS AND EDITS UPDATE ;12/26/2017
;;5.2;LAB SERVICE;**468,500**;Sep 27, 1994;Build 29
;
; This section is for sending the XML message to ISAAC via HTTP/HTTPS
;
; first we save to ^XTMP
Q
EN ; XTMP save
N LRXTMPNM,LRXTMPNUM,CNT,LRNTRTSAV
S CNT=0
ENA S LRXTMPNM="LRNTRTSAV"
L +^XTMP(LRXTMPNM):30 I '$T H 10 S CNT=CNT+1 G ENA:CNT<11,ENO
S ^XTMP(LRXTMPNM,0)=$$FMADD^XLFDT(DT,365)_U_$$NOW^XLFDT()_U_"Lab New Term to NTRT STS XML"
S LRXTMPNUM=$G(^XTMP(LRXTMPNM,"CTRL")),LRXTMPNUM=LRXTMPNUM+1,^XTMP(LRXTMPNM,"CTRL")=LRXTMPNUM
L -^XTMP(LRXTMPNM)
S CNT=0
; LRTEXT is the built XML send array
; LR60IEN is the file 60 test IEN
; LRS is the Specimen IEN from the 60 specimen multiple (60.01)
; LRDUZ is the DUZ of the person saving the test/specimen item
ENL L +^XTMP(LRXTMPNM,"SEND",LRXTMPNUM):20 I '$T H 2 S CNT=CNT+1 G ENL:CNT<11,ENO
M ^XTMP(LRXTMPNM,"SEND",LRXTMPNUM,"I")=LRTEXT
S ^XTMP(LRXTMPNM,"SEND",LRXTMPNUM,"DUZ")=LRDUZ
S ^XTMP(LRXTMPNM,"SEND",LRXTMPNUM,"LR60IEN")=LR60IEN
S ^XTMP(LRXTMPNM,"SEND",LRXTMPNUM,"LRS")=LRS
S ^XTMP(LRXTMPNM,"SEND",LRXTMPNUM,"ERROR")=0
L -^XTMP(LRXTMPNM,"SEND",LRXTMPNUM)
ENSL L +^XTMP(LRXTMPNM,"O"):5 I '$T G ENO
N ZTDTH,ZTRTN,ZTSAVE,ZTIO,ZTSK,ZTDESC
S LRNTRTSAV="LRNTRTSAV"
S ZTDTH=$$NOW^XLFDT,ZTDESC="LAB Send NTRT message to ISAAC"
S ZTSAVE("LRXTMPNM")=""
S ZTRTN="XMLSND^LRMLEDA",ZTIO=""
D ^%ZTLOAD
L -^XTMP(LRXTMPNM,"O")
K ZTDTH,ZTRTN,ZTSAVE,ZTIO,ZTSK,ZTDESC
ENO K LRXTMPNM,LRXTMPNUM,CNT,LRNTRTSAV
Q
;
; entry to send messages to ISAAC
;
XMLSND ;
N CNT,A,B,C,LRT,LRDUZ,LRG,LRS,LR60IEN,LRA,LRTEXT,LRRDAT,LRSDAT,LRRHD,LRSHD,LRFLG,LRMETH,URL,LRXTVER
N LSITE,LRNT,LRNTI,AR,LRNMAIL,LRGMAIL,LRIS,LRPRT,LRIPATH,LXA,LXB,LRNOS1,LRNOS2,LRERR,LRDUZ,LRXTMPNM
N AB,CC,DA,DIC,DIQ,DR,E,LACT,LRNOS3,LRSITEN,LXC,STATUS,XMDUZ,XMY,XMSUB,XMTEXT
S CNT=0,LRXTMPNM="LRNTRTSAV"
X1 L +^XTMP(LRXTMPNM,"O"):20 I '$T S CNT=CNT+1 G X1:CNT<11,XMLOUT
I $G(DT)="" S DT=$$DT^XLFDT
; get file 66.4 current 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
;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"))
;how to send mail
S LACT=$G(LRNTI(.02,"E"))
; Isaac web address
S LRIS=$G(LRNTI(4,"I"))
S AA=$$XUP(LRIS) S:$E(AA,1,4)="HTTP" LRIS=$P(LRIS,"//",2,999) S:$E(LRIS,($L(LRIS)))="/" LRIS=$E(LRIS,1,($L(LRIS)-1))
; Isaac port number
S LRPRT=$G(LRNTI(5,"I"))
; Isaac path
S LRIPATH=$G(LRNTI(6,"I")) I LRIPATH'="" D ;<
. S LRIPATH=$TR(LRIPATH,"~","/")
. S:$E(LRIPATH,1)'="/" LRIPATH="/"_LRIPATH
S URL=LRIS_":"_LRPRT_LRIPATH
; if web address or port number are nill do not send
S LRNOS3=0 I $G(LRNTI(4,"I"))=""!($G(LRNTI(5,"I"))="") S LRNOS3=1
;if no send method
S LRNOS1=0 I LACT=""!(LACT="N")!($G(LRNTI(.05,"I"))="N")!($G(LRNTI(.1,"I"))'=1) S LRNOS1=1
S AA=$$XUP(LRGMAIL)
; if not production or not VA
S LRNOS2=0 I '$$PROD^XUPROD()!(AA'["DOMAIN.EXT") S LRNOS2=1
;
S LRA=0,LRXTVER=1+($$PATCH^XPDUTL("XT*7.3*138"))
S LRFLG=10
X2 S LRA=$O(^XTMP(LRXTMPNM,"SEND",LRA)) I 'LRA L -^XTMP(LRXTMPNM,"O") G XMLOUT
S CNT=0
X2A L +^XTMP(LRXTMPNM,"SEND",LRA):5 I '$T S CNT=CNT+1 G X2A:CNT<11,XMLOUT
K LRT,LRRHD,LRRHD,LRSDAT,LRSHD,REDIR
S (LRRHD,LRSHD,LRRDAT)=""
S REDIR=0,LRSHD("CONTENT-TYPE")="application/xml",STATUS=""
M LRT=^XTMP(LRXTMPNM,"SEND",LRA,"I")
S LRDUZ=^XTMP(LRXTMPNM,"SEND",LRA,"DUZ"),LR60IEN=^XTMP(LRXTMPNM,"SEND",LRA,"LR60IEN")
S LRS=^XTMP(LRXTMPNM,"SEND",LRA,"LRS"),LRERR=^XTMP(LRXTMPNM,"SEND",LRA,"ERROR")
; File 60 test info
; .01 test name, 4 subscript (CH), 5 data name, 13 field (DD of 5), 64.1 result nlt code
S DA=+LR60IEN
S DIQ="LXB",DIQ(0)="IE",DIC=60,DR=".01;4;64.1;5;13;132;133" K ^UTILITY("DIQ1",$J) D EN^DIQ1 K ^UTILITY("DIQ1",$J)
K LXA M LXA=LXB(60,DA) K LXB
; get file 60 Test/Specimen info
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
; do not try if failed 10 times
I LRERR>9 D XMERR G X2
;
; check if ok to send a message
I LRNOS1=1!(LRNOS2=1)!(LRNOS3=1) D NOTVALID G X2
;
S STATUS=$$GETURL^XTHC10(URL,LRFLG,"LRRDAT",.LRRHD,"LRT",.LRSHD,$G(REDIR)+1)
S A=$TR(STATUS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
I A["OK"!(A["ACCEPTED") D G X2
.; send message to order and group that message was sent to ISAAC NTRT
. K XMY,LRTEXT
. S XMSUB="NEW NTRT REQUEST FOR LABORATORY HAS BEEN SENT"
. S XMY(LRDUZ)=""
. S XMDUZ("AUTO ISAAC NTRT PROCESS")="" I LRGMAIL'="" S XMY($P(LRGMAIL,"@",1))=""
. S LRTEXT(1)="A new Laboratory Test has been entered at: "_LRSITEN_" / "_LRSITE
. S LRTEXT(2)=""
. S LRTEXT(3)="Laboratory Test Name / Specimen name: "_$G(LXA(.01,"I"))_" / "_$G(LXC(.01,"E"))
. S LRTEXT(4)=""
. S LRTEXT(5)="Send Status: "_STATUS
. S LRTEXT(6)=""
. S A=0,B="",I=6 F S A=$O(LRRDAT(A)) Q:'A S B=$G(LRRDAT(A)) S:B'="" I=I+1,LRTEXT(I)="ISAAC Reference Information: "_B
. S LRTEXT(I+1)=""
. S XMTEXT="LRTEXT(" D ^XMD
. ;put exception flag in 60 file
. ; since making exception flag uneditable must do physical set
. 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) D ;<
. . 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
. ; remove item from send
. S ^XTMP(LRXTMPNM,"DONE",LRA)=LR60IEN_U_LRS_$$NOW^XLFDT_U_LRDUZ
. K ^XTMP(LRXTMPNM,"SEND",LRA)
. L -^XTMP(LRXTMPNM,"SEND",LRA)
. ;
S LRERR=LRERR+1,^XTMP(LRXTMPNM,"SEND",LRA,"ERROR")=LRERR,^XTMP(LRXTMPNM,"SEND",LRA,"ERROR",LRERR)=STATUS
L -^XTMP(LRXTMPNM,"SEND",LRA)
G X2
;
XMLOUT K CNT,A,B,C,LRT,LRDUZ,LRG,LRS,LR60IEN,LRA,LRTEXT,LRRDAT,LRSDAT,LRRHD,LRSHD,LRFLG,LRMETH,URL,LRXTVER
K LSITE,LRNT,LRNTI,AR,LRNMAIL,LRGMAIL,LRIS,LRPRT,LRIPATH,LXA,LXB,LRNOS1,LRNOS2,LRERR,LRDUZ,AA,LRXTMPNM
K AB,CC,DA,DIC,DIQ,DR,E,LACT,LRNOS3,LRSITEN,LXC,STATUS,XMDUZ,XMY,XMSUB,XMTEXT
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
XUP(UP) ;change to upper case
I UP="" Q ""
N A
S A=$TR(UP,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Q A
;
XMERR ; If error count is above 9 send message to LIM that request did not go out and include request in message
;
K XMY,LRTEXT
S XMSUB="NOT ABLE TO SEND NEW NTRT REQUEST FOR LABORATORY"
S XMY(LRDUZ)=""
S XMDUZ("AUTO ISAAC NTRT PROCESS")="" I LRGMAIL'="" S XMY($P(LRGMAIL,"@",1))=""
S LRTEXT(1)="A new Laboratory Test has been entered at: "_LRSITEN_" / "_LRSITE
S LRTEXT(2)=""
S LRTEXT(3)="Laboratory Test Name / Specimen name: "_$G(LXA(.01,"I"))_" / "_$G(LXC(.01,"E"))
S LRTEXT(4)=""
; the error statuses
S A=0,C=5 F S A=$O(^XTMP(LRXTMPNM,"SEND",LRA,"ERROR",A)) Q:'A S B=^XTMP(LRXTMPNM,"SEND",LRA,"ERROR",A) D ;<
. S LRTEXT(C)="Error number: "_A_" Error Reason: "_B,LRTEXT(C+1)=""
. S C=C+2
S LRTEXT(C)="Original Message Contents:",LRTEXT(C+1)="",C=C+2
S A=0 F S A=$O(LRT(A)) Q:'A S B=LRT(A),LRTEXT(C)=B,C=C+1
S LRTEXT(C)=""
S XMTEXT="LRTEXT(" D ^XMD
M ^XTMP(LRXTMPNM,"NOTSENT",LRA)=^XTMP(LRXTMPNM,"SEND",LRA)
K ^XTMP(LRXTMPNM,"SEND",LRA)
L -^XTMP(LRXTMPNM,"SEND",LRA)
Q
;
NOTVALID ; if not valid to send to ISAAC then only send MAILMAN message to
K XMY,LRTEXT
S XMSUB="NOT ABLE TO SEND NEW NTRT REQUEST FOR LABORATORY"
S XMY(LRDUZ)=""
S XMDUZ("AUTO ISAAC NTRT PROCESS")="" I LRGMAIL'="" S XMY($P(LRGMAIL,"@",1))=""
S LRTEXT(1)="A new Laboratory Test has been entered at: "_LRSITEN_" / "_LRSITE
S LRTEXT(2)=""
S LRTEXT(3)="Laboratory Test Name / Specimen name: "_$G(LXA(.01,"I"))_" / "_$G(LXC(.01,"E"))
S LRTEXT(4)=""
S LRTEXT(5)=" ** This message was not sent to ISAAC due to one of the following reasons: **"
S C=5
S A="",B="",CC="",D="",E="" S:LRNOS1=1 A="No Send Location" S:'$$PROD^XUPROD() B="Not a Production System" S:AA'["DOMAIN.EXT" CC="Not a VA System"
I LRNOS3=1 S:$G(LRNTI(4,"I"))="" D="Missing ISAAC Web Address" S:$G(LRNTI(5,"I"))="" E="Missing ISAAC Port Number"
I B'=""!(C'="") D ;<
. F I="A","B","CC","D","E" S AB=$G(@I) I AA'="" S C=C+1,LRTEXT(C)=AB
. ; I B'="" S:A'="" A=A_" , " S A=A_B
. ; I CC'="" S:A'="" A=A_" , " S A=A_CC
. ; I D'="" S:A'="" A=A_" , " S A=A_D
. ; I E'="" S:A'="" A=A_" , " S A=A_E
; S LRTEXT(6)=A,LRTEXT(7)="",C=8
S C=C+1,LRTEXT(C)="",C=C+1
S LRTEXT(C)="Original Message Contents:",LRTEXT(C+1)="",C=C+2
S A=0 F S A=$O(LRT(A)) Q:'A S B=LRT(A),LRTEXT(C)=B,C=C+1
S LRTEXT(C)=""
S XMTEXT="LRTEXT(" D ^XMD
K ^XTMP(LRXTMPNM,"SEND",LRA)
L -^XTMP(LRXTMPNM,"SEND",LRA)
Q
;
CHKACT(FILIEN) ; check if 66.3 item is active
;
N A,B,C,D
I 'FILIEN Q "0"
S (A,B,C)=""
S A=$O(^LRMLTF(FILIEN,"TERMSTATUS",9999999),-1) I 'A Q "0"
S B=$G(^LRMLTF(FILIEN,"TERMSTATUS",A,0))
I $P(B,U,2)=1 Q "1"
Q "0"
;
XML ;send xml to NTRT
; moved here from LRMLED
S ALI=0 K LRTEXT
S ALI=$$LRTP(ALI),LRTEXT(ALI)=$$XMLHDR^MXMLUTL()
; get the schemea name and the schema path
S LRSCHNM=$G(LRNTI(7,"I")),LRSCHPA=$G(LRNTI(8,"I"))
S A=$TR(LRSCHNM,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
I LRSCHNM'=""&($E(A,($L(A)-4),$L(A))'[".XSD") S LRSCHNM=LRSCHNM_".XSD"
I LRSCHPA'="" D ;<
. S LRSCHPA=$TR(LRSCHPA,"~","/")
. I $E(LRSCHPA,1,2)'="//" S LRSCHPA="//"_LRSCHPA
. I $E(LRSCHPA,$L(LRSCHPA))'="/" S LRSCHPA=LRSCHPA_"/"
S A="uri:"_LRSCHPA_LRSCHNM
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<DATAEXTRACTS xmlns="""_A_""" xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"""
S ALI=$$LRTP(ALI),LRTEXT(ALI)=">"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<LAB_NTRT>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Facility_Name-Number>"_LRSITEN_" - "_LRSITE_"</Facility_Name-Number>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Facility_Group_e-mail>"_LRGMAIL_"</Facility_Group_e-mail>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<New_Laboratory_Test_Name>"_$G(LXA(.01,"I"))_"</New_Laboratory_Test_Name>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<New_Laboratory_Test_LOCAL_IEN>"_(+LR60IEN)_"</New_Laboratory_Test_LOCAL_IEN>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Laboratory_Test_Site-Specimen_Number_IEN>"_$G(LXC(.01,"I"))_"</Laboratory_Test_Site-Specimen_Number_IEN>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Laboratory_Test_Site-Specimen_Name>"_$G(LXC(.01,"E"))_"</Laboratory_Test_Site-Specimen_Name>"
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)="<Spec>"_$P(A,U,1)_"</Spec>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Time_Aspect>"_B_"</Time_Aspect>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Units>"_$G(LXC(6,"I"))_"</Units>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<RNLT>"_LRNLT_"</RNLT>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Lab_Section>"_LRSEC_"</Lab_Section>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Subscript>"_$G(LXA(4,"I"))_"</Subscript>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Data_Name>"_LRDTNM_"</Data_Name>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Data_Comment>"_LRCOM_"</Data_Comment>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Data_Type>"_LRCTY_"</Data_Type>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Reference_Low>"_$G(LXC(1,"I"))_"</Reference_Low>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Reference_High>"_$G(LXC(2,"I"))_"</Reference_High>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Therapeutic_Low>"_$G(LXC(9.2,"I"))_"</Therapeutic_Low>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Therapeutic_High>"_$G(LXC(9.3,"I"))_"</Therapeutic_High>"
;get synonyms
K B S 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 S LXG=B(I) S:LXG'="" ALI=$$LRTP(ALI),LRTEXT(ALI)="<Test_Synonyms>"_LXG_"</Test_Synonyms>"
; specimen interpretation
;START OF CHANGE FOR LR*5.2*500
S E=0 F I=1:1 S E=$O(LXE(E)) Q:'E S G=LXE(E),ALI=$$LRTP(ALI),LRTEXT(ALI)="<Specimen_Interpretation>"_$$CHKCHAR(G)_"</Specimen_Interpretation>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Test_Creation_Date>"_$G(LXA(131,"E"))_"</Test_Creation_Date>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Specimen_Create_Date>"_$G(LXC(35,"E"))_"</Specimen_Create_Date>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<In-House_Test>"_$G(LXA(134,"E"))_"</In-House_Test>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<POC_Test>"_$G(LXA(135,"E"))_"</POC_Test>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Scanned_Image_Test>"_$G(LXA(137,"E"))_"</Scanned_Image_Test>"
S E=0 F S E=$O(LXH(E)) Q:'E D
. S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Performing_Lab>"
. S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Lab>"_$G(LXH(E,.01))_"</Lab>"
. S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Order_Code>"_$G(LXH(E,1))_"</Order_Code>"
. S ALI=$$LRTP(ALI),LRTEXT(ALI)="</Performing_Lab>"
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_Note>"
. S ALI=$$LRTP(ALI),LRTEXT(ALI)="<Date>"_$$FMTE^XLFDT(STNTDT)_"</Date>"
. S STNTIEN=0 S STNTIEN=$O(^LAB(60,LR60IEN,11,"B",STNTDT,STNTIEN)) Q:'STNTIEN D
. . S ALI=$$LRTP(ALI),LRTEXT(ALI)="<p>"
. . S I=0 F S I=$O(^LAB(60,LR60IEN,11,STNTIEN,1,I)) Q:'I D
. . . S ALI=$$LRTP(ALI),LRTEXT(ALI)=$$CHKCHAR($G(^LAB(60,LR60IEN,11,STNTIEN,1,I,0)))
. . S ALI=$$LRTP(ALI),LRTEXT(ALI)="</p>"
. S ALI=$$LRTP(ALI),LRTEXT(ALI)="</Site_Note>"
;END OF CHANGE FOR LR*5.2*500
S ALI=$$LRTP(ALI),LRTEXT(ALI)="</LAB_NTRT>"
S ALI=$$LRTP(ALI),LRTEXT(ALI)="</DATAEXTRACTS>"
G EN
Q
;
LRTP(AA) ;update text counter
S AA=AA+1
Q AA
;
CHKCHAR(A) ; check for ctrl chars, <, >, &
N B,C,I,L,M,N
I A="" Q A
S B="" F I=1:1:$L(A) S C=$E(A,I) D S L=C
. S M=$E(A,(I+1))
. I $A(C)<32!($A(C)>126) Q ; skip set
. I C="&" S N="'AND'",B=B_N Q
. I C="<" S N="'LESS THAN'",B=B_N Q
. I C=">" S N="'GREATER THAN'",B=B_N Q
. S B=B_C
Q B
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMLEDA 14130 printed Oct 16, 2024@18:18:42 Page 2
LRMLEDA ;BPFO/DTG - NTRT MESSAGE PROCESS AND EDITS UPDATE ;12/26/2017
+1 ;;5.2;LAB SERVICE;**468,500**;Sep 27, 1994;Build 29
+2 ;
+3 ; This section is for sending the XML message to ISAAC via HTTP/HTTPS
+4 ;
+5 ; first we save to ^XTMP
+6 QUIT
EN ; XTMP save
+1 NEW LRXTMPNM,LRXTMPNUM,CNT,LRNTRTSAV
+2 SET CNT=0
ENA SET LRXTMPNM="LRNTRTSAV"
+1 LOCK +^XTMP(LRXTMPNM):30
IF '$TEST
HANG 10
SET CNT=CNT+1
if CNT<11
GOTO ENA
GOTO ENO
+2 SET ^XTMP(LRXTMPNM,0)=$$FMADD^XLFDT(DT,365)_U_$$NOW^XLFDT()_U_"Lab New Term to NTRT STS XML"
+3 SET LRXTMPNUM=$GET(^XTMP(LRXTMPNM,"CTRL"))
SET LRXTMPNUM=LRXTMPNUM+1
SET ^XTMP(LRXTMPNM,"CTRL")=LRXTMPNUM
+4 LOCK -^XTMP(LRXTMPNM)
+5 SET CNT=0
+6 ; LRTEXT is the built XML send array
+7 ; LR60IEN is the file 60 test IEN
+8 ; LRS is the Specimen IEN from the 60 specimen multiple (60.01)
+9 ; LRDUZ is the DUZ of the person saving the test/specimen item
ENL LOCK +^XTMP(LRXTMPNM,"SEND",LRXTMPNUM):20
IF '$TEST
HANG 2
SET CNT=CNT+1
if CNT<11
GOTO ENL
GOTO ENO
+1 MERGE ^XTMP(LRXTMPNM,"SEND",LRXTMPNUM,"I")=LRTEXT
+2 SET ^XTMP(LRXTMPNM,"SEND",LRXTMPNUM,"DUZ")=LRDUZ
+3 SET ^XTMP(LRXTMPNM,"SEND",LRXTMPNUM,"LR60IEN")=LR60IEN
+4 SET ^XTMP(LRXTMPNM,"SEND",LRXTMPNUM,"LRS")=LRS
+5 SET ^XTMP(LRXTMPNM,"SEND",LRXTMPNUM,"ERROR")=0
+6 LOCK -^XTMP(LRXTMPNM,"SEND",LRXTMPNUM)
ENSL LOCK +^XTMP(LRXTMPNM,"O"):5
IF '$TEST
GOTO ENO
+1 NEW ZTDTH,ZTRTN,ZTSAVE,ZTIO,ZTSK,ZTDESC
+2 SET LRNTRTSAV="LRNTRTSAV"
+3 SET ZTDTH=$$NOW^XLFDT
SET ZTDESC="LAB Send NTRT message to ISAAC"
+4 SET ZTSAVE("LRXTMPNM")=""
+5 SET ZTRTN="XMLSND^LRMLEDA"
SET ZTIO=""
+6 DO ^%ZTLOAD
+7 LOCK -^XTMP(LRXTMPNM,"O")
+8 KILL ZTDTH,ZTRTN,ZTSAVE,ZTIO,ZTSK,ZTDESC
ENO KILL LRXTMPNM,LRXTMPNUM,CNT,LRNTRTSAV
+1 QUIT
+2 ;
+3 ; entry to send messages to ISAAC
+4 ;
XMLSND ;
+1 NEW CNT,A,B,C,LRT,LRDUZ,LRG,LRS,LR60IEN,LRA,LRTEXT,LRRDAT,LRSDAT,LRRHD,LRSHD,LRFLG,LRMETH,URL,LRXTVER
+2 NEW LSITE,LRNT,LRNTI,AR,LRNMAIL,LRGMAIL,LRIS,LRPRT,LRIPATH,LXA,LXB,LRNOS1,LRNOS2,LRERR,LRDUZ,LRXTMPNM
+3 NEW AB,CC,DA,DIC,DIQ,DR,E,LACT,LRNOS3,LRSITEN,LXC,STATUS,XMDUZ,XMY,XMSUB,XMTEXT
+4 SET CNT=0
SET LRXTMPNM="LRNTRTSAV"
X1 LOCK +^XTMP(LRXTMPNM,"O"):20
IF '$TEST
SET CNT=CNT+1
if CNT<11
GOTO X1
GOTO XMLOUT
+1 IF $GET(DT)=""
SET DT=$$DT^XLFDT
+2 ; get file 66.4 current info
+3 SET LSITE=$$SITE^VASITE
SET LSITE=$PIECE(LSITE,U,1)
+4 SET LRNT=$ORDER(^LAB(66.4,"B",LSITE,0))
+5 DO GETS^DIQ(66.4,LRNT_",","**","IE","AR")
+6 MERGE LRNTI=AR("66.4",LRNT_",")
KILL AR
+7 ;site number and name
+8 SET LRSITE=$GET(LRNTI(.01,"I"))
SET LRSITEN=$GET(LRNTI(.01,"E"))
+9 ;ntrt mail group
+10 SET LRNMAIL=$GET(LRNTI(1,"I"))
+11 ;lab send mail group
+12 SET LRGMAIL=$GET(LRNTI(2,"I"))
+13 ;how to send mail
+14 SET LACT=$GET(LRNTI(.02,"E"))
+15 ; Isaac web address
+16 SET LRIS=$GET(LRNTI(4,"I"))
+17 SET AA=$$XUP(LRIS)
if $EXTRACT(AA,1,4)="HTTP"
SET LRIS=$PIECE(LRIS,"//",2,999)
if $EXTRACT(LRIS,($LENGTH(LRIS)))="/"
SET LRIS=$EXTRACT(LRIS,1,($LENGTH(LRIS)-1))
+18 ; Isaac port number
+19 SET LRPRT=$GET(LRNTI(5,"I"))
+20 ; Isaac path
+21 ;<
SET LRIPATH=$GET(LRNTI(6,"I"))
IF LRIPATH'=""
Begin DoDot:1
+22 SET LRIPATH=$TRANSLATE(LRIPATH,"~","/")
+23 if $EXTRACT(LRIPATH,1)'="/"
SET LRIPATH="/"_LRIPATH
End DoDot:1
+24 SET URL=LRIS_":"_LRPRT_LRIPATH
+25 ; if web address or port number are nill do not send
+26 SET LRNOS3=0
IF $GET(LRNTI(4,"I"))=""!($GET(LRNTI(5,"I"))="")
SET LRNOS3=1
+27 ;if no send method
+28 SET LRNOS1=0
IF LACT=""!(LACT="N")!($GET(LRNTI(.05,"I"))="N")!($GET(LRNTI(.1,"I"))'=1)
SET LRNOS1=1
+29 SET AA=$$XUP(LRGMAIL)
+30 ; if not production or not VA
+31 SET LRNOS2=0
IF '$$PROD^XUPROD()!(AA'["DOMAIN.EXT")
SET LRNOS2=1
+32 ;
+33 SET LRA=0
SET LRXTVER=1+($$PATCH^XPDUTL("XT*7.3*138"))
+34 SET LRFLG=10
X2 SET LRA=$ORDER(^XTMP(LRXTMPNM,"SEND",LRA))
IF 'LRA
LOCK -^XTMP(LRXTMPNM,"O")
GOTO XMLOUT
+1 SET CNT=0
X2A LOCK +^XTMP(LRXTMPNM,"SEND",LRA):5
IF '$TEST
SET CNT=CNT+1
if CNT<11
GOTO X2A
GOTO XMLOUT
+1 KILL LRT,LRRHD,LRRHD,LRSDAT,LRSHD,REDIR
+2 SET (LRRHD,LRSHD,LRRDAT)=""
+3 SET REDIR=0
SET LRSHD("CONTENT-TYPE")="application/xml"
SET STATUS=""
+4 MERGE LRT=^XTMP(LRXTMPNM,"SEND",LRA,"I")
+5 SET LRDUZ=^XTMP(LRXTMPNM,"SEND",LRA,"DUZ")
SET LR60IEN=^XTMP(LRXTMPNM,"SEND",LRA,"LR60IEN")
+6 SET LRS=^XTMP(LRXTMPNM,"SEND",LRA,"LRS")
SET LRERR=^XTMP(LRXTMPNM,"SEND",LRA,"ERROR")
+7 ; File 60 test info
+8 ; .01 test name, 4 subscript (CH), 5 data name, 13 field (DD of 5), 64.1 result nlt code
+9 SET DA=+LR60IEN
+10 SET DIQ="LXB"
SET DIQ(0)="IE"
SET DIC=60
SET DR=".01;4;64.1;5;13;132;133"
KILL ^UTILITY("DIQ1",$JOB)
DO EN^DIQ1
KILL ^UTILITY("DIQ1",$JOB)
+11 KILL LXA
MERGE LXA=LXB(60,DA)
KILL LXB
+12 ; get file 60 Test/Specimen info
+13 SET DIQ="LXB"
SET DIQ(0)="IE"
SET DIC=60
SET DR=100
SET DA=+LR60IEN
KILL LXB,^UTILITY("DIQ1",$JOB)
+14 SET DR(60.01)=".01;6;1;2;9.2;9.3;13;30;32;33;34;35"
SET DA(60.01)=LRS
+15 DO EN^DIQ1
KILL ^UTILITY("DIQ1",$JOB)
+16 KILL LXC
MERGE LXC=LXB("60.01",LRS)
KILL LXB
+17 ; do not try if failed 10 times
+18 IF LRERR>9
DO XMERR
GOTO X2
+19 ;
+20 ; check if ok to send a message
+21 IF LRNOS1=1!(LRNOS2=1)!(LRNOS3=1)
DO NOTVALID
GOTO X2
+22 ;
+23 SET STATUS=$$GETURL^XTHC10(URL,LRFLG,"LRRDAT",.LRRHD,"LRT",.LRSHD,$GET(REDIR)+1)
+24 SET A=$TRANSLATE(STATUS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+25 IF A["OK"!(A["ACCEPTED")
Begin DoDot:1
+26 ; send message to order and group that message was sent to ISAAC NTRT
+27 KILL XMY,LRTEXT
+28 SET XMSUB="NEW NTRT REQUEST FOR LABORATORY HAS BEEN SENT"
+29 SET XMY(LRDUZ)=""
+30 SET XMDUZ("AUTO ISAAC NTRT PROCESS")=""
IF LRGMAIL'=""
SET XMY($PIECE(LRGMAIL,"@",1))=""
+31 SET LRTEXT(1)="A new Laboratory Test has been entered at: "_LRSITEN_" / "_LRSITE
+32 SET LRTEXT(2)=""
+33 SET LRTEXT(3)="Laboratory Test Name / Specimen name: "_$GET(LXA(.01,"I"))_" / "_$GET(LXC(.01,"E"))
+34 SET LRTEXT(4)=""
+35 SET LRTEXT(5)="Send Status: "_STATUS
+36 SET LRTEXT(6)=""
+37 SET A=0
SET B=""
SET I=6
FOR
SET A=$ORDER(LRRDAT(A))
if 'A
QUIT
SET B=$GET(LRRDAT(A))
if B'=""
SET I=I+1
SET LRTEXT(I)="ISAAC Reference Information: "_B
+38 SET LRTEXT(I+1)=""
+39 SET XMTEXT="LRTEXT("
DO ^XMD
+40 ;put exception flag in 60 file
+41 ; since making exception flag uneditable must do physical set
+42 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
+43 ; need to build array for saving in audit section
+44 FOR I=1,2,4
SET LRO(I)=""
SET LRN(I)=""
+45 ;<
SET LRO(3)=$PIECE(A,U,3)
SET LRN(3)=$PIECE(B,U,3)
Begin DoDot:2
+46 NEW ZTDTH,ZTRTN,ZTSAVE,ZTIO,ZTSK,ZTDESC
+47 SET ZTDTH=$$NOW^XLFDT
SET ZTDESC="LAB Edit Save of Deployed Flag"
+48 SET ZTRTN="SEDA^LRMLED("_LRS_","_LR60IEN_")"
SET ZTSAVE("LR60IEN")=""
SET ZTSAVE("LRS")=""
+49 SET ZTSAVE("LRN(")=""
SET ZTSAVE("LRO(")=""
+50 SET ZTIO=""
+51 DO ^%ZTLOAD
End DoDot:2
+52 ; remove item from send
+53 SET ^XTMP(LRXTMPNM,"DONE",LRA)=LR60IEN_U_LRS_$$NOW^XLFDT_U_LRDUZ
+54 KILL ^XTMP(LRXTMPNM,"SEND",LRA)
+55 LOCK -^XTMP(LRXTMPNM,"SEND",LRA)
+56 ;
End DoDot:1
GOTO X2
+57 SET LRERR=LRERR+1
SET ^XTMP(LRXTMPNM,"SEND",LRA,"ERROR")=LRERR
SET ^XTMP(LRXTMPNM,"SEND",LRA,"ERROR",LRERR)=STATUS
+58 LOCK -^XTMP(LRXTMPNM,"SEND",LRA)
+59 GOTO X2
+60 ;
XMLOUT KILL CNT,A,B,C,LRT,LRDUZ,LRG,LRS,LR60IEN,LRA,LRTEXT,LRRDAT,LRSDAT,LRRHD,LRSHD,LRFLG,LRMETH,URL,LRXTVER
+1 KILL LSITE,LRNT,LRNTI,AR,LRNMAIL,LRGMAIL,LRIS,LRPRT,LRIPATH,LXA,LXB,LRNOS1,LRNOS2,LRERR,LRDUZ,AA,LRXTMPNM
+2 KILL AB,CC,DA,DIC,DIQ,DR,E,LACT,LRNOS3,LRSITEN,LXC,STATUS,XMDUZ,XMY,XMSUB,XMTEXT
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
+5 ;
XUP(UP) ;change to upper case
+1 IF UP=""
QUIT ""
+2 NEW A
+3 SET A=$TRANSLATE(UP,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+4 QUIT A
+5 ;
XMERR ; If error count is above 9 send message to LIM that request did not go out and include request in message
+1 ;
+2 KILL XMY,LRTEXT
+3 SET XMSUB="NOT ABLE TO SEND NEW NTRT REQUEST FOR LABORATORY"
+4 SET XMY(LRDUZ)=""
+5 SET XMDUZ("AUTO ISAAC NTRT PROCESS")=""
IF LRGMAIL'=""
SET XMY($PIECE(LRGMAIL,"@",1))=""
+6 SET LRTEXT(1)="A new Laboratory Test has been entered at: "_LRSITEN_" / "_LRSITE
+7 SET LRTEXT(2)=""
+8 SET LRTEXT(3)="Laboratory Test Name / Specimen name: "_$GET(LXA(.01,"I"))_" / "_$GET(LXC(.01,"E"))
+9 SET LRTEXT(4)=""
+10 ; the error statuses
+11 ;<
SET A=0
SET C=5
FOR
SET A=$ORDER(^XTMP(LRXTMPNM,"SEND",LRA,"ERROR",A))
if 'A
QUIT
SET B=^XTMP(LRXTMPNM,"SEND",LRA,"ERROR",A)
Begin DoDot:1
+12 SET LRTEXT(C)="Error number: "_A_" Error Reason: "_B
SET LRTEXT(C+1)=""
+13 SET C=C+2
End DoDot:1
+14 SET LRTEXT(C)="Original Message Contents:"
SET LRTEXT(C+1)=""
SET C=C+2
+15 SET A=0
FOR
SET A=$ORDER(LRT(A))
if 'A
QUIT
SET B=LRT(A)
SET LRTEXT(C)=B
SET C=C+1
+16 SET LRTEXT(C)=""
+17 SET XMTEXT="LRTEXT("
DO ^XMD
+18 MERGE ^XTMP(LRXTMPNM,"NOTSENT",LRA)=^XTMP(LRXTMPNM,"SEND",LRA)
+19 KILL ^XTMP(LRXTMPNM,"SEND",LRA)
+20 LOCK -^XTMP(LRXTMPNM,"SEND",LRA)
+21 QUIT
+22 ;
NOTVALID ; if not valid to send to ISAAC then only send MAILMAN message to
+1 KILL XMY,LRTEXT
+2 SET XMSUB="NOT ABLE TO SEND NEW NTRT REQUEST FOR LABORATORY"
+3 SET XMY(LRDUZ)=""
+4 SET XMDUZ("AUTO ISAAC NTRT PROCESS")=""
IF LRGMAIL'=""
SET XMY($PIECE(LRGMAIL,"@",1))=""
+5 SET LRTEXT(1)="A new Laboratory Test has been entered at: "_LRSITEN_" / "_LRSITE
+6 SET LRTEXT(2)=""
+7 SET LRTEXT(3)="Laboratory Test Name / Specimen name: "_$GET(LXA(.01,"I"))_" / "_$GET(LXC(.01,"E"))
+8 SET LRTEXT(4)=""
+9 SET LRTEXT(5)=" ** This message was not sent to ISAAC due to one of the following reasons: **"
+10 SET C=5
+11 SET A=""
SET B=""
SET CC=""
SET D=""
SET E=""
if LRNOS1=1
SET A="No Send Location"
if '$$PROD^XUPROD()
SET B="Not a Production System"
if AA'["DOMAIN.EXT"
SET CC="Not a VA System"
+12 IF LRNOS3=1
if $GET(LRNTI(4,"I"))=""
SET D="Missing ISAAC Web Address"
if $GET(LRNTI(5,"I"))=""
SET E="Missing ISAAC Port Number"
+13 ;<
IF B'=""!(C'="")
Begin DoDot:1
+14 FOR I="A","B","CC","D","E"
SET AB=$GET(@I)
IF AA'=""
SET C=C+1
SET LRTEXT(C)=AB
+15 ; I B'="" S:A'="" A=A_" , " S A=A_B
+16 ; I CC'="" S:A'="" A=A_" , " S A=A_CC
+17 ; I D'="" S:A'="" A=A_" , " S A=A_D
+18 ; I E'="" S:A'="" A=A_" , " S A=A_E
End DoDot:1
+19 ; S LRTEXT(6)=A,LRTEXT(7)="",C=8
+20 SET C=C+1
SET LRTEXT(C)=""
SET C=C+1
+21 SET LRTEXT(C)="Original Message Contents:"
SET LRTEXT(C+1)=""
SET C=C+2
+22 SET A=0
FOR
SET A=$ORDER(LRT(A))
if 'A
QUIT
SET B=LRT(A)
SET LRTEXT(C)=B
SET C=C+1
+23 SET LRTEXT(C)=""
+24 SET XMTEXT="LRTEXT("
DO ^XMD
+25 KILL ^XTMP(LRXTMPNM,"SEND",LRA)
+26 LOCK -^XTMP(LRXTMPNM,"SEND",LRA)
+27 QUIT
+28 ;
CHKACT(FILIEN) ; check if 66.3 item is active
+1 ;
+2 NEW A,B,C,D
+3 IF 'FILIEN
QUIT "0"
+4 SET (A,B,C)=""
+5 SET A=$ORDER(^LRMLTF(FILIEN,"TERMSTATUS",9999999),-1)
IF 'A
QUIT "0"
+6 SET B=$GET(^LRMLTF(FILIEN,"TERMSTATUS",A,0))
+7 IF $PIECE(B,U,2)=1
QUIT "1"
+8 QUIT "0"
+9 ;
XML ;send xml to NTRT
+1 ; moved here from LRMLED
+2 SET ALI=0
KILL LRTEXT
+3 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=$$XMLHDR^MXMLUTL()
+4 ; get the schemea name and the schema path
+5 SET LRSCHNM=$GET(LRNTI(7,"I"))
SET LRSCHPA=$GET(LRNTI(8,"I"))
+6 SET A=$TRANSLATE(LRSCHNM,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+7 IF LRSCHNM'=""&($EXTRACT(A,($LENGTH(A)-4),$LENGTH(A))'[".XSD")
SET LRSCHNM=LRSCHNM_".XSD"
+8 ;<
IF LRSCHPA'=""
Begin DoDot:1
+9 SET LRSCHPA=$TRANSLATE(LRSCHPA,"~","/")
+10 IF $EXTRACT(LRSCHPA,1,2)'="//"
SET LRSCHPA="//"_LRSCHPA
+11 IF $EXTRACT(LRSCHPA,$LENGTH(LRSCHPA))'="/"
SET LRSCHPA=LRSCHPA_"/"
End DoDot:1
+12 SET A="uri:"_LRSCHPA_LRSCHNM
+13 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<DATAEXTRACTS xmlns="""_A_""" xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"""
+14 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=">"
+15 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<LAB_NTRT>"
+16 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Facility_Name-Number>"_LRSITEN_" - "_LRSITE_"</Facility_Name-Number>"
+17 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Facility_Group_e-mail>"_LRGMAIL_"</Facility_Group_e-mail>"
+18 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<New_Laboratory_Test_Name>"_$GET(LXA(.01,"I"))_"</New_Laboratory_Test_Name>"
+19 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<New_Laboratory_Test_LOCAL_IEN>"_(+LR60IEN)_"</New_Laboratory_Test_LOCAL_IEN>"
+20 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Laboratory_Test_Site-Specimen_Number_IEN>"_$GET(LXC(.01,"I"))_"</Laboratory_Test_Site-Specimen_Number_IEN>"
+21 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Laboratory_Test_Site-Specimen_Name>"_$GET(LXC(.01,"E"))_"</Laboratory_Test_Site-Specimen_Name>"
+22 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)
+23 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Spec>"_$PIECE(A,U,1)_"</Spec>"
+24 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Time_Aspect>"_B_"</Time_Aspect>"
+25 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Units>"_$GET(LXC(6,"I"))_"</Units>"
+26 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<RNLT>"_LRNLT_"</RNLT>"
+27 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Lab_Section>"_LRSEC_"</Lab_Section>"
+28 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Subscript>"_$GET(LXA(4,"I"))_"</Subscript>"
+29 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Data_Name>"_LRDTNM_"</Data_Name>"
+30 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Data_Comment>"_LRCOM_"</Data_Comment>"
+31 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Data_Type>"_LRCTY_"</Data_Type>"
+32 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Reference_Low>"_$GET(LXC(1,"I"))_"</Reference_Low>"
+33 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Reference_High>"_$GET(LXC(2,"I"))_"</Reference_High>"
+34 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Therapeutic_Low>"_$GET(LXC(9.2,"I"))_"</Therapeutic_Low>"
+35 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Therapeutic_High>"_$GET(LXC(9.3,"I"))_"</Therapeutic_High>"
+36 ;get synonyms
+37 KILL B
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)
+38 IF I>0
SET B=I-1
FOR I=0:1:B
SET LXG=B(I)
if LXG'=""
SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Test_Synonyms>"_LXG_"</Test_Synonyms>"
+39 ; specimen interpretation
+40 ;START OF CHANGE FOR LR*5.2*500
+41 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)="<Specimen_Interpretation>"_$$CHKCHAR(G)_"</Specimen_Interpretation>"
+42 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Test_Creation_Date>"_$GET(LXA(131,"E"))_"</Test_Creation_Date>"
+43 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Specimen_Create_Date>"_$GET(LXC(35,"E"))_"</Specimen_Create_Date>"
+44 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<In-House_Test>"_$GET(LXA(134,"E"))_"</In-House_Test>"
+45 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<POC_Test>"_$GET(LXA(135,"E"))_"</POC_Test>"
+46 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Scanned_Image_Test>"_$GET(LXA(137,"E"))_"</Scanned_Image_Test>"
+47 SET E=0
FOR
SET E=$ORDER(LXH(E))
if 'E
QUIT
Begin DoDot:1
+48 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Performing_Lab>"
+49 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Lab>"_$GET(LXH(E,.01))_"</Lab>"
+50 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Order_Code>"_$GET(LXH(E,1))_"</Order_Code>"
+51 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="</Performing_Lab>"
End DoDot:1
+52 NEW STNTDT
SET STNTDT=9999999
FOR
SET STNTDT=$ORDER(^LAB(60,LR60IEN,11,"B",STNTDT),-1)
if 'STNTDT
QUIT
Begin DoDot:1
+53 NEW STNTIEN,I
+54 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Site_Note>"
+55 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<Date>"_$$FMTE^XLFDT(STNTDT)_"</Date>"
+56 SET STNTIEN=0
SET STNTIEN=$ORDER(^LAB(60,LR60IEN,11,"B",STNTDT,STNTIEN))
if 'STNTIEN
QUIT
Begin DoDot:2
+57 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="<p>"
+58 SET I=0
FOR
SET I=$ORDER(^LAB(60,LR60IEN,11,STNTIEN,1,I))
if 'I
QUIT
Begin DoDot:3
+59 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)=$$CHKCHAR($GET(^LAB(60,LR60IEN,11,STNTIEN,1,I,0)))
End DoDot:3
+60 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="</p>"
End DoDot:2
+61 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="</Site_Note>"
End DoDot:1
+62 ;END OF CHANGE FOR LR*5.2*500
+63 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="</LAB_NTRT>"
+64 SET ALI=$$LRTP(ALI)
SET LRTEXT(ALI)="</DATAEXTRACTS>"
+65 GOTO EN
+66 QUIT
+67 ;
LRTP(AA) ;update text counter
+1 SET AA=AA+1
+2 QUIT AA
+3 ;
CHKCHAR(A) ; check for ctrl chars, <, >, &
+1 NEW B,C,I,L,M,N
+2 IF A=""
QUIT A
+3 SET B=""
FOR I=1:1:$LENGTH(A)
SET C=$EXTRACT(A,I)
Begin DoDot:1
+4 SET M=$EXTRACT(A,(I+1))
+5 ; skip set
IF $ASCII(C)<32!($ASCII(C)>126)
QUIT
+6 IF C="&"
SET N="'AND'"
SET B=B_N
QUIT
+7 IF C="<"
SET N="'LESS THAN'"
SET B=B_N
QUIT
+8 IF C=">"
SET N="'GREATER THAN'"
SET B=B_N
QUIT
+9 SET B=B_C
End DoDot:1
SET L=C
+10 QUIT B
+11 ;
