LRSRVR ;DALOI/RLM/JMC - LAB DATA SERVER ;11/18/11 16:47
;;5.2;LAB SERVICE;**232,303,346,350,468,495**;Sep 27, 1994;Build 6
;
; Reference to ^%ZOSF supported by IA #10096
; Reference to $$SITE^VASITE supported by IA #10112
;
; 5.2;LAB SERVICE; CHANGE FOR PATCH LR*5.2*468; Feb 10 2016
; 5.2;LAB SERVICE; CHANGE FOR PATCH LR*5.2*495; Jul 10 2017
;
START ;
N LRSITE,LRST,LRSUB,LRXMZ
;
; Save incoming server message id for cleanup
S LRXMZ=XMZ
;
K ^TMP($J,"LRDATA"),^TMP($J,"LRDTERR")
; Determine station name and number
S LRSITE=$$SITE^VASITE,LRSTN=$P(LRSITE,"^",2),LRST=$P(LRSITE,"^",3)
I LRST="" S LRST="???"
;
S LRSUB=$$UP^XLFSTR(XQSUB)
;
; The first line of the message tells who requested the action and when
; The second line tells when the server is activated and no data can be
; gathered from the MailMan message. This line gets replaced if the
; server finds something to do.
S ^TMP($J,"LRDATA",1)=LRSUB_" triggered at "_LRSTN_" by "_XMFROM_" on "_XQDATE
S LRACTION=$S(LRSUB["CHECKSUM":"Checksums Generated",1:LRSUB)
S ^TMP($J,"LRDATA",2)="I don't know how to "_LRACTION_" at "_LRSTN
;
;
; If the subject contains "CHECKSUM" send a report of the current checksums to the LABTEAM group on RDMAIL
I LRSUB["CHECKSUM" D CSUM Q
;
; If the subject contains "LIST" send a report based on the list of routines in the body of the message back to the original sender.
I LRSUB["LIST" D SUMLST Q
;
; If the subject equals "LOINC" send the local LOINC data to the national list.
I LRSUB="LOINC" D LOINC^LRSRVR1 Q
;
; If the subject contains "LOCAL REPORT" send the local LOINC data to the sender.
I LRSUB="LOCAL REPORT" D LOINCL^LRSRVR1 Q
I LRSUB="LOCAL REPORT DELIMIT" D LOINCLD^LRSRVR3 Q
;
; Send RELMA mapper formatted message
I LRSUB="RELMA" D SERVER^LRSRVR2 Q
; Process RELMA mapper Packman global message
I LRSUB="RELMA MAPPING" D RMAP^LRSRVR5 Q
;
; Send SNOMED mapping formatted message
I LRSUB="SNOMED" D SERVER^LRSRVR6 Q
I LRSUB="SNOMED MAPPING" D CTMAP^LRSRVR5 Q
;
; Send NLT/CPT mapping formatted message
I LRSUB="NLT/CPT" D SERVER^LRSRVR7 Q
;
;START OF CHANGE FOR LR*5.2*468
I LRSUB="MLTF" D SERVER^LRSRVR9 Q
;END OF CHANGE FOR LR*5.2*468
;
;START OF CHANGE FOR LR*5.2*495 receive file updates for 61,61.2,62
I LRSUB["SCTLOAD" D SERVER^LRSRVR9B Q
;END OF CHANGE FOR LR*5.2*495
;
; If subject not understood by server, send a message to the sender
; that the server can't understand their instructions.
K XMY
S XMY(XQSND)=""
;
EXIT ; If all went well, report that too.
; Mail the errors and successes back to the Roll-Up group at Forum.
N LRNOW
S LRNOW=$$NOW^XLFDT
S XMDUN="Lab Server",XMDUZ=".5",XMSUB=LRSTN_" LAB SERVER ("_LRNOW_")"
S XMTEXT="^TMP($J,""LRDATA"","
I '$D(XMY) S XMY("G.LABTEAM@ISC-DOMAIN.EXT")=""
D ^XMD
;
CLEAN ; Cleanup and exit
I $D(^TMP($J,"LRDTERR")) D
. S XMDUN="Lab Server",XMDUZ=".5"
. S XMSUB=LRSTN_" LAB SERVER ERROR ("_LRNOW_")"
. S XMTEXT="^TMP($J,""LRDTERR"","
. S XMY("G.LABTEAM@ISC-DOMAIN.EXT")="",XMY(XQSND)=""
. D ^XMD
;
; Clean up server message in MailMan
I $G(LRXMZ)>0 D ZAPSERV^XMXAPI("S.LRLABSERVER",LRXMZ)
;
K %,%DT,%H,D,DD,DIC,DIERR,ERROR,FILL,LINE,LOINCDTA,LOINCDTB,LOINCTAS
K LRA,LRAA,LRACTION,LRB,LRCLST,LRDA,LRERR,LRFOUND,LRFOUND1,LRI,LRLINE
K LRNDE,LROUT,LRPNT,LRPNTA,LRPNTB,LRRDT,LRRN,LRROOT,LRST,LRSTN,LRSUB
K X,XMDUN,XMDUZ,XMER,XMFROM,XMREC,XMRG,XMSUB,XMTEXT,XMY,XMZ,XQDATE
K XQSND,XQSUB,Y,ZTQUEUED,ZTSK
;
K ^TMP($J,"LRDATA"),^TMP($J,"LRDTERR")
S:$D(ZTQUEUED) ZTREQ="@"
Q
;
;
CSUM ;Calculate checksum for routines and transmit errors to LABTEAM group
S X=$T(+0) X ^%ZOSF("RSUM") S ^TMP($J,"LRDATA",2)=X_" at "_LRSTN_" = "_Y
S LRI=0
F S LRI=$O(^LAB(69.91,1,"ROU",LRI)) Q:'LRI D
. S X=$P(^LAB(69.91,1,"ROU",LRI,0),"^")
. S LRA=$P(^LAB(69.91,1,"ROU",LRI,0),"^",4)
. X ^%ZOSF("TEST") I '$T S ^TMP($J,"LRDATA",LRI+3)=X_" is missing." Q
. X ^%ZOSF("RSUM") I +$G(Y)'=LRA S ^TMP($J,"LRDATA",LRI+3)=X_" should be "_LRA_" is "_+$G(Y)
S XMSUB="Lab Checksum data at "_LRSTN_" run on "_XQDATE
D EXIT
Q
;
;
SUMLST ;Calculate checksum for routines and transmit to requestor
K ^TMP($J,"LRDATA"),^TMP($J,"LRDTERR")
S LRCLST=$P($$SITE^VASITE,"^",2),LINE=2,$P(FILL," ",8)=""
S ^TMP($J,"LRDATA",1)="Lab Server triggered at "_LRCLST_" by "_XMFROM_" on "_XQDATE
;
; Check for a plus sign in front of the routine name. Bypass the
; Test to see if the routine exists if it's there.
; DSM won't check %routines to make sure they exist, Cache will.
F X XMREC Q:XMER<0 S X=XMRG D
. I X'?1"+".E X ^%ZOSF("TEST") I '$T S ^TMP($J,"LRDATA",LINE)=X_$E(FILL,$L(X),8)_" is missing.",LINE=LINE+1 Q
. ;Strip off the plus sign so that the checksum routine can find it.
. S X=$TR(X,"+","")
. X ^%ZOSF("RSUM") S ^TMP($J,"LRDATA",LINE)=X_$E(FILL,$L(X),8)_" is "_Y,LINE=LINE+1
S XMSUB="Checksum data at "_LRCLST_" run on "_XQDATE
S XMY(XQSND)=""
D EXIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSRVR 5034 printed Apr 09, 2024@21:20:46 Page 2
LRSRVR ;DALOI/RLM/JMC - LAB DATA SERVER ;11/18/11 16:47
+1 ;;5.2;LAB SERVICE;**232,303,346,350,468,495**;Sep 27, 1994;Build 6
+2 ;
+3 ; Reference to ^%ZOSF supported by IA #10096
+4 ; Reference to $$SITE^VASITE supported by IA #10112
+5 ;
+6 ; 5.2;LAB SERVICE; CHANGE FOR PATCH LR*5.2*468; Feb 10 2016
+7 ; 5.2;LAB SERVICE; CHANGE FOR PATCH LR*5.2*495; Jul 10 2017
+8 ;
START ;
+1 NEW LRSITE,LRST,LRSUB,LRXMZ
+2 ;
+3 ; Save incoming server message id for cleanup
+4 SET LRXMZ=XMZ
+5 ;
+6 KILL ^TMP($JOB,"LRDATA"),^TMP($JOB,"LRDTERR")
+7 ; Determine station name and number
+8 SET LRSITE=$$SITE^VASITE
SET LRSTN=$PIECE(LRSITE,"^",2)
SET LRST=$PIECE(LRSITE,"^",3)
+9 IF LRST=""
SET LRST="???"
+10 ;
+11 SET LRSUB=$$UP^XLFSTR(XQSUB)
+12 ;
+13 ; The first line of the message tells who requested the action and when
+14 ; The second line tells when the server is activated and no data can be
+15 ; gathered from the MailMan message. This line gets replaced if the
+16 ; server finds something to do.
+17 SET ^TMP($JOB,"LRDATA",1)=LRSUB_" triggered at "_LRSTN_" by "_XMFROM_" on "_XQDATE
+18 SET LRACTION=$SELECT(LRSUB["CHECKSUM":"Checksums Generated",1:LRSUB)
+19 SET ^TMP($JOB,"LRDATA",2)="I don't know how to "_LRACTION_" at "_LRSTN
+20 ;
+21 ;
+22 ; If the subject contains "CHECKSUM" send a report of the current checksums to the LABTEAM group on RDMAIL
+23 IF LRSUB["CHECKSUM"
DO CSUM
QUIT
+24 ;
+25 ; If the subject contains "LIST" send a report based on the list of routines in the body of the message back to the original sender.
+26 IF LRSUB["LIST"
DO SUMLST
QUIT
+27 ;
+28 ; If the subject equals "LOINC" send the local LOINC data to the national list.
+29 IF LRSUB="LOINC"
DO LOINC^LRSRVR1
QUIT
+30 ;
+31 ; If the subject contains "LOCAL REPORT" send the local LOINC data to the sender.
+32 IF LRSUB="LOCAL REPORT"
DO LOINCL^LRSRVR1
QUIT
+33 IF LRSUB="LOCAL REPORT DELIMIT"
DO LOINCLD^LRSRVR3
QUIT
+34 ;
+35 ; Send RELMA mapper formatted message
+36 IF LRSUB="RELMA"
DO SERVER^LRSRVR2
QUIT
+37 ; Process RELMA mapper Packman global message
+38 IF LRSUB="RELMA MAPPING"
DO RMAP^LRSRVR5
QUIT
+39 ;
+40 ; Send SNOMED mapping formatted message
+41 IF LRSUB="SNOMED"
DO SERVER^LRSRVR6
QUIT
+42 IF LRSUB="SNOMED MAPPING"
DO CTMAP^LRSRVR5
QUIT
+43 ;
+44 ; Send NLT/CPT mapping formatted message
+45 IF LRSUB="NLT/CPT"
DO SERVER^LRSRVR7
QUIT
+46 ;
+47 ;START OF CHANGE FOR LR*5.2*468
+48 IF LRSUB="MLTF"
DO SERVER^LRSRVR9
QUIT
+49 ;END OF CHANGE FOR LR*5.2*468
+50 ;
+51 ;START OF CHANGE FOR LR*5.2*495 receive file updates for 61,61.2,62
+52 IF LRSUB["SCTLOAD"
DO SERVER^LRSRVR9B
QUIT
+53 ;END OF CHANGE FOR LR*5.2*495
+54 ;
+55 ; If subject not understood by server, send a message to the sender
+56 ; that the server can't understand their instructions.
+57 KILL XMY
+58 SET XMY(XQSND)=""
+59 ;
EXIT ; If all went well, report that too.
+1 ; Mail the errors and successes back to the Roll-Up group at Forum.
+2 NEW LRNOW
+3 SET LRNOW=$$NOW^XLFDT
+4 SET XMDUN="Lab Server"
SET XMDUZ=".5"
SET XMSUB=LRSTN_" LAB SERVER ("_LRNOW_")"
+5 SET XMTEXT="^TMP($J,""LRDATA"","
+6 IF '$DATA(XMY)
SET XMY("G.LABTEAM@ISC-DOMAIN.EXT")=""
+7 DO ^XMD
+8 ;
CLEAN ; Cleanup and exit
+1 IF $DATA(^TMP($JOB,"LRDTERR"))
Begin DoDot:1
+2 SET XMDUN="Lab Server"
SET XMDUZ=".5"
+3 SET XMSUB=LRSTN_" LAB SERVER ERROR ("_LRNOW_")"
+4 SET XMTEXT="^TMP($J,""LRDTERR"","
+5 SET XMY("G.LABTEAM@ISC-DOMAIN.EXT")=""
SET XMY(XQSND)=""
+6 DO ^XMD
End DoDot:1
+7 ;
+8 ; Clean up server message in MailMan
+9 IF $GET(LRXMZ)>0
DO ZAPSERV^XMXAPI("S.LRLABSERVER",LRXMZ)
+10 ;
+11 KILL %,%DT,%H,D,DD,DIC,DIERR,ERROR,FILL,LINE,LOINCDTA,LOINCDTB,LOINCTAS
+12 KILL LRA,LRAA,LRACTION,LRB,LRCLST,LRDA,LRERR,LRFOUND,LRFOUND1,LRI,LRLINE
+13 KILL LRNDE,LROUT,LRPNT,LRPNTA,LRPNTB,LRRDT,LRRN,LRROOT,LRST,LRSTN,LRSUB
+14 KILL X,XMDUN,XMDUZ,XMER,XMFROM,XMREC,XMRG,XMSUB,XMTEXT,XMY,XMZ,XQDATE
+15 KILL XQSND,XQSUB,Y,ZTQUEUED,ZTSK
+16 ;
+17 KILL ^TMP($JOB,"LRDATA"),^TMP($JOB,"LRDTERR")
+18 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+19 QUIT
+20 ;
+21 ;
CSUM ;Calculate checksum for routines and transmit errors to LABTEAM group
+1 SET X=$TEXT(+0)
XECUTE ^%ZOSF("RSUM")
SET ^TMP($JOB,"LRDATA",2)=X_" at "_LRSTN_" = "_Y
+2 SET LRI=0
+3 FOR
SET LRI=$ORDER(^LAB(69.91,1,"ROU",LRI))
if 'LRI
QUIT
Begin DoDot:1
+4 SET X=$PIECE(^LAB(69.91,1,"ROU",LRI,0),"^")
+5 SET LRA=$PIECE(^LAB(69.91,1,"ROU",LRI,0),"^",4)
+6 XECUTE ^%ZOSF("TEST")
IF '$TEST
SET ^TMP($JOB,"LRDATA",LRI+3)=X_" is missing."
QUIT
+7 XECUTE ^%ZOSF("RSUM")
IF +$GET(Y)'=LRA
SET ^TMP($JOB,"LRDATA",LRI+3)=X_" should be "_LRA_" is "_+$GET(Y)
End DoDot:1
+8 SET XMSUB="Lab Checksum data at "_LRSTN_" run on "_XQDATE
+9 DO EXIT
+10 QUIT
+11 ;
+12 ;
SUMLST ;Calculate checksum for routines and transmit to requestor
+1 KILL ^TMP($JOB,"LRDATA"),^TMP($JOB,"LRDTERR")
+2 SET LRCLST=$PIECE($$SITE^VASITE,"^",2)
SET LINE=2
SET $PIECE(FILL," ",8)=""
+3 SET ^TMP($JOB,"LRDATA",1)="Lab Server triggered at "_LRCLST_" by "_XMFROM_" on "_XQDATE
+4 ;
+5 ; Check for a plus sign in front of the routine name. Bypass the
+6 ; Test to see if the routine exists if it's there.
+7 ; DSM won't check %routines to make sure they exist, Cache will.
+8 FOR
XECUTE XMREC
if XMER<0
QUIT
SET X=XMRG
Begin DoDot:1
+9 IF X'?1"+".E
XECUTE ^%ZOSF("TEST")
IF '$TEST
SET ^TMP($JOB,"LRDATA",LINE)=X_$EXTRACT(FILL,$LENGTH(X),8)_" is missing."
SET LINE=LINE+1
QUIT
+10 ;Strip off the plus sign so that the checksum routine can find it.
+11 SET X=$TRANSLATE(X,"+","")
+12 XECUTE ^%ZOSF("RSUM")
SET ^TMP($JOB,"LRDATA",LINE)=X_$EXTRACT(FILL,$LENGTH(X),8)_" is "_Y
SET LINE=LINE+1
End DoDot:1
+13 SET XMSUB="Checksum data at "_LRCLST_" run on "_XQDATE
+14 SET XMY(XQSND)=""
+15 DO EXIT
+16 QUIT
