LRSRVR6 ;DALOI/JMC,TMK - LAB DATA SERVER CONT'D SNOMED EXTRACT ; 17 Apr 2013 2:03 PM
;;5.2;LAB SERVICE;**346,378,350,425,460,495**;Sep 27, 1994;Build 6
;
; 5.2;LAB SERVICE; CHANGE FOR PATCH LR*5.2*495; Jul 10 2017
;
; Produces SNOMED extract via LRLABSERVER option
;
; **** NOTE: if record format is changed then update corresponding extract record building in LRERT ***
Q
;
;
SERVER ; Server entry Point
N I,LRCNT,LREND,LRL,LRMSUBJ,LRST,LRSTN,LRTXT,LRX,LRY
D BUILD
S LRMSUBJ=LRST_" "_LRSTN_" SNOMED EXTRACT "_$$HTE^XLFDT($H,"1M")
D MAILSEND(LRMSUBJ)
D CLEAN
Q
;
;
BUILD ; Build extract
;
N I,J,LRCNT,LRCRLF,LRETIME,LRFN,LRLEX,LRNAME,LRNODE,LRQUIT,LRROOT,LRSCT,LRSCTEC,LRSCTVER,LRSCTX,LRSPEC,LRSTIME,LRSTR,LRVAL,LRVUID,LRX,LRY,X,Y
;
;ZEXCEPT: LRST,LRSTN
;
S LRSTIME=$$NOW^XLFDT,LRVAL=$$SITE^VASITE,LRST=$P(LRVAL,"^",3),LRSTN=$P(LRVAL,"^",2),LRSCTVER=""
I LRST="" S LRST="???"
K ^TMP($J,"LRDATA")
S (LRCNT,LRCNT("SCT"),LRCNT("SCT","EC"))=0,LRCRLF=$C(13,10),LRSTR=""
F I=61,61.1,61.2,61.3,61.4,61.5,61.6,62 S (LRCNT(I),LRCNT(I,"SCT"),LRCNT(I,"SCT","EC"))=0
D HDR
;
; Flag to indicate if SNOMED CT is available from LEXICON.
S LRLEX=0
I $T(CODE^LEXTRAN)'="" S LRLEX=1
;
F LRFN=61,61.1,61.2,61.3,61.4,61.5,61.6,62 D
. S LRROOT="^LAB("_LRFN_",""B"")"
. D FILE
;
S LRETIME=$$NOW^XLFDT
; Set the final info into the ^TMP message global
S LRNODE=$O(^TMP($J,"LRDATA",""),-1)
I LRSTR'="" S LRNODE=LRNODE+1,^TMP($J,"LRDATA",LRNODE)=$$UUEN^LRSRVR4(LRSTR)
S ^TMP($J,"LRDATA",LRNODE+1)=" "
S ^TMP($J,"LRDATA",LRNODE+2)="end"
;
S ^TMP($J,"LRDATA",1)=^TMP($J,"LRDATA",1)_" (Run time:"_$$FMDIFF^XLFDT(LRETIME,LRSTIME,3)_")"
S ^TMP($J,"LRDATA",3)="SNOMED CT version......: "_LRSCTVER
S J=6
S ^TMP($J,"LRDATA",J)="Number of records per file:"
F I=61,61.1,61.2,61.3,61.4,61.5,61.6,62 D
. S J=J+1
. S ^TMP($J,"LRDATA",J)=" "_$$LJ^XLFSTR($$GET1^DID(I,"","","NAME")_" File (#"_I_")",32,".")_": "_$J(LRCNT(I),5)_" ("_LRCNT(I,"SCT")_" mapped)"
. I LRCNT(I,"SCT","EC") S ^TMP($J,"LRDATA",J)=^TMP($J,"LRDATA",J)_" ("_LRCNT(I,"SCT","EC")_" exceptions)"
S ^TMP($J,"LRDATA",J+1)=$$LJ^XLFSTR("Total number of records",33,".")_": "_$J(LRCNT,5)_" ("_LRCNT("SCT")_" mapped)"
I LRCNT("SCT","EC") S ^TMP($J,"LRDATA",J+1)=^TMP($J,"LRDATA",J+1)_" ("_LRCNT("SCT","EC")_" exceptions)"
;
Q
;
;
CLEAN ;
;
;ZEXCEPT: LRIEN,LRLEN,LRNODE,LRSNM,LRSPECN
;
K ^TMP($J,"LR61")
K LRIEN,LRLEN,LRNODE,LRSNM,LRSPECN
D CLEAN^LRSRVR
D ^%ZISC
Q
;
;
FILE ; Search file entry and build record.
;
N LRNAME,LRVFLD,X
;
;ZEXCEPT: LRCNT,LRFN,LRIEN,LRLEX,LRROOT,LRSCT,LRSCTEC,LRSCTVER,LRSCTX,LRSNM,LRSPEC,LRSPECN,LRST,LRSTR,LRVUID,LRX
;
;
S LRVFLD(21)=$$VFIELD^DILFD(LRFN,21)
F S LRROOT=$Q(@LRROOT) Q:LRROOT="" Q:$QS(LRROOT,2)'="B" D
. S LRIEN=$QS(LRROOT,4),LRSPEC=""
. S LRNAME=$P($G(^LAB(LRFN,LRIEN,0)),"^") ;,LRNAME=$$TRIM^XLFSTR(LRNAME,"RL"," ")
. I $G(@LRROOT),LRNAME'=$QS(LRROOT,3) Q
. S X=$P($G(^LAB(LRFN,LRIEN,0)),"^",2)
. S LRSNM=$S(LRFN'=62:X,1:"")
. I LRFN=62 S LRSPEC=X
. I LRSNM'="",LRFN>60.9,LRFN<61.61 S LRX=((LRFN*10)#610)+1,LRSNM=$E("TMEFDPJ",LRX)_"-"_LRSNM
. S LRSCT=$P($G(^LAB(LRFN,LRIEN,"SCT")),"^"),(LRSCTEC,LRSCTX,LRVUID)=""
. I LRLEX,LRSCT'="" D
. . N LRLEXARR
. . S LRLEXARR=$$CODE^LRSCT(LRSCT,"SCT",DT,"LRLEXARR")
. . S LRSCTX=$G(LRLEXARR("F")),LRSCTEC=$S(LRLEXARR<1:$P(LRLEXARR,"^",2),1:"")
. . I LRSCTVER="",LRLEXARR>0 S LRSCTVER=$P($G(LRLEXARR(0)),"^",3)
. S LRSTR=LRSTR_LRST_"-"_LRFN_"-"_LRIEN_"|"_LRNAME_"|"_LRSNM_"|"_LRVUID_"|"_LRSCT_"|"_LRSCTX_"|"_LRSCTEC_"|"
. S LRSPECN="|"
. I LRFN=62,LRSPEC D
. . S LRSPECN=$P($G(^LAB(61,LRSPEC,0)),"^")
. . S LRSPECN=LRSPECN_"|"_LRST_"-61-"_LRSPEC
. S LRSTR=LRSTR_LRSPECN_"|1.2|"
. I LRVFLD(21) S LRSTR=LRSTR_$$GET1^DIQ(LRFN,LRIEN_",",21,"I")
. S LRSTR=LRSTR_"|"
. ;START OF CHANGE FOR LR*5.2*495 to Send Inactive date for 61.2
. ;I LRFN=61!(LRFN=62) D ; Inactive date
. I LRFN=61!(LRFN=62)!(LRFN=61.2) D ; Inactive date
.. I LRFN=61 S LRSTR=LRSTR_$TR($$FMTE^XLFDT($$GET1^DIQ(LRFN,LRIEN_",",64.9103,"I"),"1D")," ,","/")
.. I LRFN=62 S LRSTR=LRSTR_$TR($$FMTE^XLFDT($$GET1^DIQ(LRFN,LRIEN_",",64.9101,"I"),"1D")," ,","/")
.. I LRFN=61.2 S LRSTR=LRSTR_$TR($$FMTE^XLFDT($$GET1^DIQ(LRFN,LRIEN_",",64.9102,"I"),"1D")," ,","/")
.. ;END OF CHANGE FOR LR*5.2*495
.. S LRSTR=LRSTR_"|"
. S LRCNT=LRCNT+1,LRCNT(LRFN)=LRCNT(LRFN)+1
. I LRSCT D
. . S LRCNT("SCT")=LRCNT("SCT")+1,LRCNT(LRFN,"SCT")=LRCNT(LRFN,"SCT")+1
. . I LRSCTEC'="" S LRCNT("SCT","EC")=LRCNT("SCT","EC")+1,LRCNT(LRFN,"SCT","EC")=LRCNT(LRFN,"SCT","EC")+1
. D SETDATA
Q
;
;
SETDATA ; Set data into report structure
;
;ZEXCEPT: LRCRLF,LRNODE,LRSTR
;
S LRSTR=LRSTR_LRCRLF
S LRNODE=$O(^TMP($J,"LRDATA",""),-1)
D ENCODE^LRSRVR4(.LRSTR)
Q
;
;
HDR ; Set the header information
N I,LRFILENM,X
;
;ZEXCEPT: LRSCTVER,LRSTIME,LRSTN,LRSUB
;
S LRFILENM=$TR(LRSTN," ","_")_"-"_LRSUB_"-"_$P($$FMTHL7^XLFDT(LRSTIME),"-")_".TXT"
S ^TMP($J,"LRDATA",1)="Report Generated.......: "_$$FMTE^XLFDT(LRSTIME)_" at "_LRSTN
S ^TMP($J,"LRDATA",2)="Report requested.......: "_LRSUB
S ^TMP($J,"LRDATA",3)="SNOMED CT version......: "_LRSCTVER
S ^TMP($J,"LRDATA",4)="Extract version........: "_$$VER()
F I=5,15,16,18,23 S ^TMP($J,"LRDATA",I)=" "
S ^TMP($J,"LRDATA",17)="Attached file..........: "_LRFILENM
S ^TMP($J,"LRDATA",19)="Legend:"
S X="Station #-File #-IEN|Entry Name|SNOMED I|VUID|SNOMED CT|SNOMED CT TERM|Mapping Exception|Related Specimen|Related Specimen ID|Extract Ver|Term Status|Inactive Date|"
S ^TMP($J,"LRDATA",20)=X
S X=" 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 |"
S ^TMP($J,"LRDATA",21)=X
S ^TMP($J,"LRDATA",22)=$$REPEAT^XLFSTR("-",$L(X))
S ^TMP($J,"LRDATA",24)=$$UUBEGFN^LRSRVR2A(LRFILENM)
Q
;
;
VER() ; Extract version
Q "1.2"
;
;
MAILSEND(LRMSUBJ) ; Send extract back to requestor.
;
N LRINSTR,LRTASK,LRTO,XMERR,XMZ
;
;ZEXCEPT: XQSND
;
S LRTO(XQSND)=""
S LRINSTR("ADDR FLAGS")="R"
S LRINSTR("FROM")="LAB_PACKAGE"
S LRMSUBJ=$E(LRMSUBJ,1,65)
D SENDMSG^XMXAPI(.5,LRMSUBJ,"^TMP($J,""LRDATA"")",.LRTO,.LRINSTR,.LRTASK)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSRVR6 6312 printed Apr 09, 2024@21:17:56 Page 2
LRSRVR6 ;DALOI/JMC,TMK - LAB DATA SERVER CONT'D SNOMED EXTRACT ; 17 Apr 2013 2:03 PM
+1 ;;5.2;LAB SERVICE;**346,378,350,425,460,495**;Sep 27, 1994;Build 6
+2 ;
+3 ; 5.2;LAB SERVICE; CHANGE FOR PATCH LR*5.2*495; Jul 10 2017
+4 ;
+5 ; Produces SNOMED extract via LRLABSERVER option
+6 ;
+7 ; **** NOTE: if record format is changed then update corresponding extract record building in LRERT ***
+8 QUIT
+9 ;
+10 ;
SERVER ; Server entry Point
+1 NEW I,LRCNT,LREND,LRL,LRMSUBJ,LRST,LRSTN,LRTXT,LRX,LRY
+2 DO BUILD
+3 SET LRMSUBJ=LRST_" "_LRSTN_" SNOMED EXTRACT "_$$HTE^XLFDT($HOROLOG,"1M")
+4 DO MAILSEND(LRMSUBJ)
+5 DO CLEAN
+6 QUIT
+7 ;
+8 ;
BUILD ; Build extract
+1 ;
+2 NEW I,J,LRCNT,LRCRLF,LRETIME,LRFN,LRLEX,LRNAME,LRNODE,LRQUIT,LRROOT,LRSCT,LRSCTEC,LRSCTVER,LRSCTX,LRSPEC,LRSTIME,LRSTR,LRVAL,LRVUID,LRX,LRY,X,Y
+3 ;
+4 ;ZEXCEPT: LRST,LRSTN
+5 ;
+6 SET LRSTIME=$$NOW^XLFDT
SET LRVAL=$$SITE^VASITE
SET LRST=$PIECE(LRVAL,"^",3)
SET LRSTN=$PIECE(LRVAL,"^",2)
SET LRSCTVER=""
+7 IF LRST=""
SET LRST="???"
+8 KILL ^TMP($JOB,"LRDATA")
+9 SET (LRCNT,LRCNT("SCT"),LRCNT("SCT","EC"))=0
SET LRCRLF=$CHAR(13,10)
SET LRSTR=""
+10 FOR I=61,61.1,61.2,61.3,61.4,61.5,61.6,62
SET (LRCNT(I),LRCNT(I,"SCT"),LRCNT(I,"SCT","EC"))=0
+11 DO HDR
+12 ;
+13 ; Flag to indicate if SNOMED CT is available from LEXICON.
+14 SET LRLEX=0
+15 IF $TEXT(CODE^LEXTRAN)'=""
SET LRLEX=1
+16 ;
+17 FOR LRFN=61,61.1,61.2,61.3,61.4,61.5,61.6,62
Begin DoDot:1
+18 SET LRROOT="^LAB("_LRFN_",""B"")"
+19 DO FILE
End DoDot:1
+20 ;
+21 SET LRETIME=$$NOW^XLFDT
+22 ; Set the final info into the ^TMP message global
+23 SET LRNODE=$ORDER(^TMP($JOB,"LRDATA",""),-1)
+24 IF LRSTR'=""
SET LRNODE=LRNODE+1
SET ^TMP($JOB,"LRDATA",LRNODE)=$$UUEN^LRSRVR4(LRSTR)
+25 SET ^TMP($JOB,"LRDATA",LRNODE+1)=" "
+26 SET ^TMP($JOB,"LRDATA",LRNODE+2)="end"
+27 ;
+28 SET ^TMP($JOB,"LRDATA",1)=^TMP($JOB,"LRDATA",1)_" (Run time:"_$$FMDIFF^XLFDT(LRETIME,LRSTIME,3)_")"
+29 SET ^TMP($JOB,"LRDATA",3)="SNOMED CT version......: "_LRSCTVER
+30 SET J=6
+31 SET ^TMP($JOB,"LRDATA",J)="Number of records per file:"
+32 FOR I=61,61.1,61.2,61.3,61.4,61.5,61.6,62
Begin DoDot:1
+33 SET J=J+1
+34 SET ^TMP($JOB,"LRDATA",J)=" "_$$LJ^XLFSTR($$GET1^DID(I,"","","NAME")_" File (#"_I_")",32,".")_": "_$JUSTIFY(LRCNT(I),5)_" ("_LRCNT(I,"SCT")_" mapped)"
+35 IF LRCNT(I,"SCT","EC")
SET ^TMP($JOB,"LRDATA",J)=^TMP($JOB,"LRDATA",J)_" ("_LRCNT(I,"SCT","EC")_" exceptions)"
End DoDot:1
+36 SET ^TMP($JOB,"LRDATA",J+1)=$$LJ^XLFSTR("Total number of records",33,".")_": "_$JUSTIFY(LRCNT,5)_" ("_LRCNT("SCT")_" mapped)"
+37 IF LRCNT("SCT","EC")
SET ^TMP($JOB,"LRDATA",J+1)=^TMP($JOB,"LRDATA",J+1)_" ("_LRCNT("SCT","EC")_" exceptions)"
+38 ;
+39 QUIT
+40 ;
+41 ;
CLEAN ;
+1 ;
+2 ;ZEXCEPT: LRIEN,LRLEN,LRNODE,LRSNM,LRSPECN
+3 ;
+4 KILL ^TMP($JOB,"LR61")
+5 KILL LRIEN,LRLEN,LRNODE,LRSNM,LRSPECN
+6 DO CLEAN^LRSRVR
+7 DO ^%ZISC
+8 QUIT
+9 ;
+10 ;
FILE ; Search file entry and build record.
+1 ;
+2 NEW LRNAME,LRVFLD,X
+3 ;
+4 ;ZEXCEPT: LRCNT,LRFN,LRIEN,LRLEX,LRROOT,LRSCT,LRSCTEC,LRSCTVER,LRSCTX,LRSNM,LRSPEC,LRSPECN,LRST,LRSTR,LRVUID,LRX
+5 ;
+6 ;
+7 SET LRVFLD(21)=$$VFIELD^DILFD(LRFN,21)
+8 FOR
SET LRROOT=$QUERY(@LRROOT)
if LRROOT=""
QUIT
if $QSUBSCRIPT(LRROOT,2)'="B"
QUIT
Begin DoDot:1
+9 SET LRIEN=$QSUBSCRIPT(LRROOT,4)
SET LRSPEC=""
+10 ;,LRNAME=$$TRIM^XLFSTR(LRNAME,"RL"," ")
SET LRNAME=$PIECE($GET(^LAB(LRFN,LRIEN,0)),"^")
+11 IF $GET(@LRROOT)
IF LRNAME'=$QSUBSCRIPT(LRROOT,3)
QUIT
+12 SET X=$PIECE($GET(^LAB(LRFN,LRIEN,0)),"^",2)
+13 SET LRSNM=$SELECT(LRFN'=62:X,1:"")
+14 IF LRFN=62
SET LRSPEC=X
+15 IF LRSNM'=""
IF LRFN>60.9
IF LRFN<61.61
SET LRX=((LRFN*10)#610)+1
SET LRSNM=$EXTRACT("TMEFDPJ",LRX)_"-"_LRSNM
+16 SET LRSCT=$PIECE($GET(^LAB(LRFN,LRIEN,"SCT")),"^")
SET (LRSCTEC,LRSCTX,LRVUID)=""
+17 IF LRLEX
IF LRSCT'=""
Begin DoDot:2
+18 NEW LRLEXARR
+19 SET LRLEXARR=$$CODE^LRSCT(LRSCT,"SCT",DT,"LRLEXARR")
+20 SET LRSCTX=$GET(LRLEXARR("F"))
SET LRSCTEC=$SELECT(LRLEXARR<1:$PIECE(LRLEXARR,"^",2),1:"")
+21 IF LRSCTVER=""
IF LRLEXARR>0
SET LRSCTVER=$PIECE($GET(LRLEXARR(0)),"^",3)
End DoDot:2
+22 SET LRSTR=LRSTR_LRST_"-"_LRFN_"-"_LRIEN_"|"_LRNAME_"|"_LRSNM_"|"_LRVUID_"|"_LRSCT_"|"_LRSCTX_"|"_LRSCTEC_"|"
+23 SET LRSPECN="|"
+24 IF LRFN=62
IF LRSPEC
Begin DoDot:2
+25 SET LRSPECN=$PIECE($GET(^LAB(61,LRSPEC,0)),"^")
+26 SET LRSPECN=LRSPECN_"|"_LRST_"-61-"_LRSPEC
End DoDot:2
+27 SET LRSTR=LRSTR_LRSPECN_"|1.2|"
+28 IF LRVFLD(21)
SET LRSTR=LRSTR_$$GET1^DIQ(LRFN,LRIEN_",",21,"I")
+29 SET LRSTR=LRSTR_"|"
+30 ;START OF CHANGE FOR LR*5.2*495 to Send Inactive date for 61.2
+31 ;I LRFN=61!(LRFN=62) D ; Inactive date
+32 ; Inactive date
IF LRFN=61!(LRFN=62)!(LRFN=61.2)
Begin DoDot:2
+33 IF LRFN=61
SET LRSTR=LRSTR_$TRANSLATE($$FMTE^XLFDT($$GET1^DIQ(LRFN,LRIEN_",",64.9103,"I"),"1D")," ,","/")
+34 IF LRFN=62
SET LRSTR=LRSTR_$TRANSLATE($$FMTE^XLFDT($$GET1^DIQ(LRFN,LRIEN_",",64.9101,"I"),"1D")," ,","/")
+35 IF LRFN=61.2
SET LRSTR=LRSTR_$TRANSLATE($$FMTE^XLFDT($$GET1^DIQ(LRFN,LRIEN_",",64.9102,"I"),"1D")," ,","/")
+36 ;END OF CHANGE FOR LR*5.2*495
+37 SET LRSTR=LRSTR_"|"
End DoDot:2
+38 SET LRCNT=LRCNT+1
SET LRCNT(LRFN)=LRCNT(LRFN)+1
+39 IF LRSCT
Begin DoDot:2
+40 SET LRCNT("SCT")=LRCNT("SCT")+1
SET LRCNT(LRFN,"SCT")=LRCNT(LRFN,"SCT")+1
+41 IF LRSCTEC'=""
SET LRCNT("SCT","EC")=LRCNT("SCT","EC")+1
SET LRCNT(LRFN,"SCT","EC")=LRCNT(LRFN,"SCT","EC")+1
End DoDot:2
+42 DO SETDATA
End DoDot:1
+43 QUIT
+44 ;
+45 ;
SETDATA ; Set data into report structure
+1 ;
+2 ;ZEXCEPT: LRCRLF,LRNODE,LRSTR
+3 ;
+4 SET LRSTR=LRSTR_LRCRLF
+5 SET LRNODE=$ORDER(^TMP($JOB,"LRDATA",""),-1)
+6 DO ENCODE^LRSRVR4(.LRSTR)
+7 QUIT
+8 ;
+9 ;
HDR ; Set the header information
+1 NEW I,LRFILENM,X
+2 ;
+3 ;ZEXCEPT: LRSCTVER,LRSTIME,LRSTN,LRSUB
+4 ;
+5 SET LRFILENM=$TRANSLATE(LRSTN," ","_")_"-"_LRSUB_"-"_$PIECE($$FMTHL7^XLFDT(LRSTIME),"-")_".TXT"
+6 SET ^TMP($JOB,"LRDATA",1)="Report Generated.......: "_$$FMTE^XLFDT(LRSTIME)_" at "_LRSTN
+7 SET ^TMP($JOB,"LRDATA",2)="Report requested.......: "_LRSUB
+8 SET ^TMP($JOB,"LRDATA",3)="SNOMED CT version......: "_LRSCTVER
+9 SET ^TMP($JOB,"LRDATA",4)="Extract version........: "_$$VER()
+10 FOR I=5,15,16,18,23
SET ^TMP($JOB,"LRDATA",I)=" "
+11 SET ^TMP($JOB,"LRDATA",17)="Attached file..........: "_LRFILENM
+12 SET ^TMP($JOB,"LRDATA",19)="Legend:"
+13 SET X="Station #-File #-IEN|Entry Name|SNOMED I|VUID|SNOMED CT|SNOMED CT TERM|Mapping Exception|Related Specimen|Related Specimen ID|Extract Ver|Term Status|Inactive Date|"
+14 SET ^TMP($JOB,"LRDATA",20)=X
+15 SET X=" 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 |"
+16 SET ^TMP($JOB,"LRDATA",21)=X
+17 SET ^TMP($JOB,"LRDATA",22)=$$REPEAT^XLFSTR("-",$LENGTH(X))
+18 SET ^TMP($JOB,"LRDATA",24)=$$UUBEGFN^LRSRVR2A(LRFILENM)
+19 QUIT
+20 ;
+21 ;
VER() ; Extract version
+1 QUIT "1.2"
+2 ;
+3 ;
MAILSEND(LRMSUBJ) ; Send extract back to requestor.
+1 ;
+2 NEW LRINSTR,LRTASK,LRTO,XMERR,XMZ
+3 ;
+4 ;ZEXCEPT: XQSND
+5 ;
+6 SET LRTO(XQSND)=""
+7 SET LRINSTR("ADDR FLAGS")="R"
+8 SET LRINSTR("FROM")="LAB_PACKAGE"
+9 SET LRMSUBJ=$EXTRACT(LRMSUBJ,1,65)
+10 DO SENDMSG^XMXAPI(.5,LRMSUBJ,"^TMP($J,""LRDATA"")",.LRTO,.LRINSTR,.LRTASK)
+11 QUIT
