- 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 Feb 18, 2025@23:43:50 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 ;