LRSRVR7 ;DALIO/JMC - LAB DATA SERVER CONT'D CPT EXTRACT ;Aug 17, 2006
;;5.2;LAB SERVICE;**346**;Sep 27, 1994;Build 10
; Produces NLT/CPT extract via LRLABSERVER option
;
Q
;
;
SERVER ; Server entry Point
N I,LRCNT,LREND,LRL,LRMSUBJ,LRST,LRSTN,LRTXT,LRX,LRY
D BUILD
S LRMSUBJ=LRST_" "_LRSTN_" NLT/CPT EXTRACT "_$$HTE^XLFDT($H,"1M")
D MAILSEND^LRSRVR6(LRMSUBJ)
D CLEAN
Q
;
;
BUILD ; Build extract
N LRCNT,LRCRLF,LRFN,LRNAME,LRQUIT,LRROOT,LRSCT,LRSTR,LRVAL,LRVUID,X,Y
;
S LRVAL=$$SITE^VASITE,LRST=$P(LRVAL,"^",3),LRSTN=$P(LRVAL,"^",2)
I LRST="" S LRST="???"
K ^TMP($J,"LRDATA")
S (LRCNT,LRCNT(1),LRCNT(2))=0,LRCRLF=$C(13,10),LRSTR=""
D HDR,FILE
;
;
; Set the final info into the ^TMP message global
S LRNODE=$O(^TMP($J,"LRDATA",""),-1)+1
I LRSTR'="" S ^TMP($J,"LRDATA",LRNODE)=$$UUEN^LRSRVR4(LRSTR)
S ^TMP($J,"LRDATA",LRNODE+1)=" "
S ^TMP($J,"LRDATA",LRNODE+2)="end"
;
S J=4
S ^TMP($J,"LRDATA",J)="Number of records per file:"
S ^TMP($J,"LRDATA",J+1)=$$LJ^XLFSTR("Total number of records",33,".")_": "_$J(LRCNT,5)
S ^TMP($J,"LRDATA",J+2)=$$LJ^XLFSTR("CPT/LOINC records",33,".")_": "_$J(LRCNT(1),5)
S ^TMP($J,"LRDATA",J+3)=$$LJ^XLFSTR("CPT/Default LOINC records",33,".")_": "_$J(LRCNT(2),5)
;
Q
;
;
CLEAN ;
K ^TMP($J,"LR61")
K J,LA7PCNT,LR64CODE,LR64NM,LRFILENM,LRLEN,LRLN,LRLNC,LRNODE,LRSTSYN
D CLEAN^LRSRVR
D ^%ZISC
Q
;
;
FILE ;
;
N LR64,LR64018,LR81,LRCPT,LRCPTNM,LRI,LRXX,LRYY,LRZ
S LRROOT="^LAM(""AD"")",(LR64,LR64018)=0
F S LRROOT=$Q(@LRROOT) Q:LRROOT="" Q:$QS(LRROOT,1)'="AD" D
. I $QS(LRROOT,3)'="CPT" Q
. I LR64'=$QS(LRROOT,2) D
. . S LR64=$QS(LRROOT,2)
. . S X=$G(^LAM(LR64,0))
. . S LR64NM=$P(X,"^"),LR64CODE=$P(X,"^",2)
. . D LOINC
. . S LRCNT=LRCNT+1
. S LR64018=$QS(LRROOT,4)
. S LR81=+$P($G(^LAM(LR64,4,LR64018,0)),"^")
. S X=$$CPT^ICPTCOD(LR81,DT,1)
. S LRCPT=$S($P(X,"^")>0:$P(X,"^",2),1:"IEN "_LR81)
. S LRCPTNM=$S($P(X,"^")>0:$P(X,"^",3),1:$P(X,"^",2))
. ; File "default" mapping
. S LRSTR=LRSTR_LRST_"-"_LR64_"-"_LR64018_"|"_LR64CODE_"|"_LR64NM_"|"_LRCPT_"|"_LRCPTNM_"|"_LRLN
. D SETDATA
. ; File specific specimen/time aspect LOINC mappings
. S LRXX=LRST_"-"_LR64_"-"_LR64018_"-"
. S LRYY="|"_LR64CODE_"|"_LR64NM_"|"_LRCPT_"|"_LRCPTNM_"|"
. S LRI=""
. F S LRI=$O(LRLN(LRI)) Q:LRI="" D
. . S LRSTR=LRSTR_LRXX_LRI_LRYY_LRLN(LRI)
. . D SETDATA
Q
;
;
SETDATA ; Set data into report structure
S LRSTR=LRSTR_LRCRLF
S LRNODE=$O(^TMP($J,"LRDATA",""),-1)
D ENCODE^LRSRVR4(.LRSTR)
Q
;
;
HDR ; Set the header information
S LRFILENM=$TR(LRSTN," ","_")_"-"_LRSUB_"-"_$P($$FMTHL7^XLFDT($$NOW^XLFDT),"-")_".TXT"
S ^TMP($J,"LRDATA",1)="Report generated.......: "_$$FMTE^XLFDT($$NOW^XLFDT)_" at "_LRSTN
S ^TMP($J,"LRDATA",2)="Report requested.......: "_LRSUB
F I=3,8,10,15 S ^TMP($J,"LRDATA",I)=" "
S ^TMP($J,"LRDATA",9)="Attached file..........: "_LRFILENM
S ^TMP($J,"LRDATA",11)="Legend:"
S X="Station #-NLT IEN-CPT IEN-Spec-Time Aspect|NLT Code|NLT Name|CPT Code|CPT Name|Specimen|Time Aspect|LOINC Code|LOINC Short Name|"
S ^TMP($J,"LRDATA",12)=X
S X=" 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 |"
S ^TMP($J,"LRDATA",13)=X
S ^TMP($J,"LRDATA",14)=$$REPEAT^XLFSTR("-",$L(X))
S ^TMP($J,"LRDATA",16)=$$UUBEGFN^LRSRVR2A(LRFILENM)
Q
;
;
LOINC ; Retreive any LOINC codes for the NLT code
N LR61,LRJ,LRK,LRSPECN,LRTA,LRX
K LRLN
; Default LOINC
S LRX=$G(^LAM(LR64,9))
S LRLN="||||"
I $P(LRX,"^") D
. S $P(LRLN,"|",3)=$$GET1^DIQ(95.3,$P(LRX,"^")_",",.01)
. S $P(LRLN,"|",4)=$$GET1^DIQ(95.3,$P(LRX,"^")_",",81)
. S LRCNT(2)=LRCNT(2)+1
I $P(LRX,"^",2) S $P(LRLN,"|",2)=$P($G(^LAB(64.061,$P(LRX,"^",2),0)),"^")
;
; Specimen specific LOINC
S LRJ=0
F S LRJ=$O(^LAM(LR64,5,LRJ)) Q:'LRJ D
. S LR61=+$P($G(^LAM(LR64,5,LRJ,0)),"^")
. S LRSPECN=$P($G(^LAB(61,LR61,0)),"^")
. S LRK=0
. F S LRK=$O(^LAM(LR64,5,LRJ,1,LRK)) Q:'LRK D
. . S LRTA=$P($G(^LAM(LR64,5,LRJ,1,LRK,0)),"^")
. . S LRLNC=$P($G(^LAM(LR64,5,LRJ,1,LRK,1)),"^")
. . S LRLN(LRJ_"-"_LRK)=LRSPECN_"|"_$P($G(^LAB(64.061,LRTA,0)),"^")_"|"_$$GET1^DIQ(95.3,LRLNC_",",.01)_"|"_$$GET1^DIQ(95.3,LRLNC_",",81)_"|"
. . S LRCNT(1)=LRCNT(1)+1
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSRVR7 4321 printed Jan 18, 2025@03:21:36 Page 2
LRSRVR7 ;DALIO/JMC - LAB DATA SERVER CONT'D CPT EXTRACT ;Aug 17, 2006
+1 ;;5.2;LAB SERVICE;**346**;Sep 27, 1994;Build 10
+2 ; Produces NLT/CPT extract via LRLABSERVER option
+3 ;
+4 QUIT
+5 ;
+6 ;
SERVER ; Server entry Point
+1 NEW I,LRCNT,LREND,LRL,LRMSUBJ,LRST,LRSTN,LRTXT,LRX,LRY
+2 DO BUILD
+3 SET LRMSUBJ=LRST_" "_LRSTN_" NLT/CPT EXTRACT "_$$HTE^XLFDT($HOROLOG,"1M")
+4 DO MAILSEND^LRSRVR6(LRMSUBJ)
+5 DO CLEAN
+6 QUIT
+7 ;
+8 ;
BUILD ; Build extract
+1 NEW LRCNT,LRCRLF,LRFN,LRNAME,LRQUIT,LRROOT,LRSCT,LRSTR,LRVAL,LRVUID,X,Y
+2 ;
+3 SET LRVAL=$$SITE^VASITE
SET LRST=$PIECE(LRVAL,"^",3)
SET LRSTN=$PIECE(LRVAL,"^",2)
+4 IF LRST=""
SET LRST="???"
+5 KILL ^TMP($JOB,"LRDATA")
+6 SET (LRCNT,LRCNT(1),LRCNT(2))=0
SET LRCRLF=$CHAR(13,10)
SET LRSTR=""
+7 DO HDR
DO FILE
+8 ;
+9 ;
+10 ; Set the final info into the ^TMP message global
+11 SET LRNODE=$ORDER(^TMP($JOB,"LRDATA",""),-1)+1
+12 IF LRSTR'=""
SET ^TMP($JOB,"LRDATA",LRNODE)=$$UUEN^LRSRVR4(LRSTR)
+13 SET ^TMP($JOB,"LRDATA",LRNODE+1)=" "
+14 SET ^TMP($JOB,"LRDATA",LRNODE+2)="end"
+15 ;
+16 SET J=4
+17 SET ^TMP($JOB,"LRDATA",J)="Number of records per file:"
+18 SET ^TMP($JOB,"LRDATA",J+1)=$$LJ^XLFSTR("Total number of records",33,".")_": "_$JUSTIFY(LRCNT,5)
+19 SET ^TMP($JOB,"LRDATA",J+2)=$$LJ^XLFSTR("CPT/LOINC records",33,".")_": "_$JUSTIFY(LRCNT(1),5)
+20 SET ^TMP($JOB,"LRDATA",J+3)=$$LJ^XLFSTR("CPT/Default LOINC records",33,".")_": "_$JUSTIFY(LRCNT(2),5)
+21 ;
+22 QUIT
+23 ;
+24 ;
CLEAN ;
+1 KILL ^TMP($JOB,"LR61")
+2 KILL J,LA7PCNT,LR64CODE,LR64NM,LRFILENM,LRLEN,LRLN,LRLNC,LRNODE,LRSTSYN
+3 DO CLEAN^LRSRVR
+4 DO ^%ZISC
+5 QUIT
+6 ;
+7 ;
FILE ;
+1 ;
+2 NEW LR64,LR64018,LR81,LRCPT,LRCPTNM,LRI,LRXX,LRYY,LRZ
+3 SET LRROOT="^LAM(""AD"")"
SET (LR64,LR64018)=0
+4 FOR
SET LRROOT=$QUERY(@LRROOT)
if LRROOT=""
QUIT
if $QSUBSCRIPT(LRROOT,1)'="AD"
QUIT
Begin DoDot:1
+5 IF $QSUBSCRIPT(LRROOT,3)'="CPT"
QUIT
+6 IF LR64'=$QSUBSCRIPT(LRROOT,2)
Begin DoDot:2
+7 SET LR64=$QSUBSCRIPT(LRROOT,2)
+8 SET X=$GET(^LAM(LR64,0))
+9 SET LR64NM=$PIECE(X,"^")
SET LR64CODE=$PIECE(X,"^",2)
+10 DO LOINC
+11 SET LRCNT=LRCNT+1
End DoDot:2
+12 SET LR64018=$QSUBSCRIPT(LRROOT,4)
+13 SET LR81=+$PIECE($GET(^LAM(LR64,4,LR64018,0)),"^")
+14 SET X=$$CPT^ICPTCOD(LR81,DT,1)
+15 SET LRCPT=$SELECT($PIECE(X,"^")>0:$PIECE(X,"^",2),1:"IEN "_LR81)
+16 SET LRCPTNM=$SELECT($PIECE(X,"^")>0:$PIECE(X,"^",3),1:$PIECE(X,"^",2))
+17 ; File "default" mapping
+18 SET LRSTR=LRSTR_LRST_"-"_LR64_"-"_LR64018_"|"_LR64CODE_"|"_LR64NM_"|"_LRCPT_"|"_LRCPTNM_"|"_LRLN
+19 DO SETDATA
+20 ; File specific specimen/time aspect LOINC mappings
+21 SET LRXX=LRST_"-"_LR64_"-"_LR64018_"-"
+22 SET LRYY="|"_LR64CODE_"|"_LR64NM_"|"_LRCPT_"|"_LRCPTNM_"|"
+23 SET LRI=""
+24 FOR
SET LRI=$ORDER(LRLN(LRI))
if LRI=""
QUIT
Begin DoDot:2
+25 SET LRSTR=LRSTR_LRXX_LRI_LRYY_LRLN(LRI)
+26 DO SETDATA
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
+29 ;
SETDATA ; Set data into report structure
+1 SET LRSTR=LRSTR_LRCRLF
+2 SET LRNODE=$ORDER(^TMP($JOB,"LRDATA",""),-1)
+3 DO ENCODE^LRSRVR4(.LRSTR)
+4 QUIT
+5 ;
+6 ;
HDR ; Set the header information
+1 SET LRFILENM=$TRANSLATE(LRSTN," ","_")_"-"_LRSUB_"-"_$PIECE($$FMTHL7^XLFDT($$NOW^XLFDT),"-")_".TXT"
+2 SET ^TMP($JOB,"LRDATA",1)="Report generated.......: "_$$FMTE^XLFDT($$NOW^XLFDT)_" at "_LRSTN
+3 SET ^TMP($JOB,"LRDATA",2)="Report requested.......: "_LRSUB
+4 FOR I=3,8,10,15
SET ^TMP($JOB,"LRDATA",I)=" "
+5 SET ^TMP($JOB,"LRDATA",9)="Attached file..........: "_LRFILENM
+6 SET ^TMP($JOB,"LRDATA",11)="Legend:"
+7 SET X="Station #-NLT IEN-CPT IEN-Spec-Time Aspect|NLT Code|NLT Name|CPT Code|CPT Name|Specimen|Time Aspect|LOINC Code|LOINC Short Name|"
+8 SET ^TMP($JOB,"LRDATA",12)=X
+9 SET X=" 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 |"
+10 SET ^TMP($JOB,"LRDATA",13)=X
+11 SET ^TMP($JOB,"LRDATA",14)=$$REPEAT^XLFSTR("-",$LENGTH(X))
+12 SET ^TMP($JOB,"LRDATA",16)=$$UUBEGFN^LRSRVR2A(LRFILENM)
+13 QUIT
+14 ;
+15 ;
LOINC ; Retreive any LOINC codes for the NLT code
+1 NEW LR61,LRJ,LRK,LRSPECN,LRTA,LRX
+2 KILL LRLN
+3 ; Default LOINC
+4 SET LRX=$GET(^LAM(LR64,9))
+5 SET LRLN="||||"
+6 IF $PIECE(LRX,"^")
Begin DoDot:1
+7 SET $PIECE(LRLN,"|",3)=$$GET1^DIQ(95.3,$PIECE(LRX,"^")_",",.01)
+8 SET $PIECE(LRLN,"|",4)=$$GET1^DIQ(95.3,$PIECE(LRX,"^")_",",81)
+9 SET LRCNT(2)=LRCNT(2)+1
End DoDot:1
+10 IF $PIECE(LRX,"^",2)
SET $PIECE(LRLN,"|",2)=$PIECE($GET(^LAB(64.061,$PIECE(LRX,"^",2),0)),"^")
+11 ;
+12 ; Specimen specific LOINC
+13 SET LRJ=0
+14 FOR
SET LRJ=$ORDER(^LAM(LR64,5,LRJ))
if 'LRJ
QUIT
Begin DoDot:1
+15 SET LR61=+$PIECE($GET(^LAM(LR64,5,LRJ,0)),"^")
+16 SET LRSPECN=$PIECE($GET(^LAB(61,LR61,0)),"^")
+17 SET LRK=0
+18 FOR
SET LRK=$ORDER(^LAM(LR64,5,LRJ,1,LRK))
if 'LRK
QUIT
Begin DoDot:2
+19 SET LRTA=$PIECE($GET(^LAM(LR64,5,LRJ,1,LRK,0)),"^")
+20 SET LRLNC=$PIECE($GET(^LAM(LR64,5,LRJ,1,LRK,1)),"^")
+21 SET LRLN(LRJ_"-"_LRK)=LRSPECN_"|"_$PIECE($GET(^LAB(64.061,LRTA,0)),"^")_"|"_$$GET1^DIQ(95.3,LRLNC_",",.01)_"|"_$$GET1^DIQ(95.3,LRLNC_",",81)_"|"
+22 SET LRCNT(1)=LRCNT(1)+1
End DoDot:2
End DoDot:1
+23 ;
+24 QUIT
