HDISDSR ;BPFO/DTG - HDI MAILMAN SERVER FOR COLLECTING SDO; Apr 07, 2018@12:42
;;1.0;HEALTH DATA & INFORMATICS;**22**;Feb 22, 2005;Build 26
;
START ;
N A,HDISITE,HDIST,HDISUB,HDIXMZ,HDISV,HDER,HDICRLF,HDIJB,HDILEN,HDIMSUBJ,HDIQUIT,HDITXT,HDINODE
N HDIMAX
;
; Save incoming server message id for cleanup
S HDIXMZ=XMZ
;
S HDISV="^TMP($J,""HDIDATA"")",HDER="^TMP($J,""HDIDTERR"")"
K @HDISV,@HDER
; Determine station name and number
S HDISITE=$$SITE^VASITE,HDISTN=$P(HDISITE,"^",2),HDIST=$P(HDISITE,"^",3)
I HDIST="" S HDIST="???"
;
S HDISUB=$$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 A="SDO lookup option: "_HDISUB_$J(" ",6)
S ^TMP($J,"HDIDATA",1)=A
S A="Was triggered at "_HDISTN_" by "_XMFROM_" on "_XQDATE_$J(" ",6)
S ^TMP($J,"HDIDATA",2)=A
S ^TMP($J,"HDIDATA",3)=" "_$J(" ",6)
S HDIACTON=HDISUB
S A="This SDO lookup option: "_HDIACTON_$J(" ",6)
S ^TMP($J,"HDIDATA",4)=A
S A="Is NOT available at "_HDISTN_$J(" ",6)
S ^TMP($J,"HDIDATA",5)=A
S A=""
;
;
I HDISUB="LAB" D EN1^HDISDSRL Q
;
; 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 HDINOW
S HDINOW=$$NOW^XLFDT,A=$$FMTE^XLFDT(HDINOW,5)
S XMDUN="HDI SDO Server",XMDUZ=".5",XMSUB=HDISTN_" HDI SDO SERVER ("_A_" ["_HDINOW_"])"
K XMTEXT S XMTEXT="^TMP($J,""HDIDATA"","
I '$D(XMY) S XMY($G(XQSND))=""
N DIFROM D ^XMD K DIFROM
;
CLEAN ; Cleanup and exit
I $D(^TMP($J,"HDIDTERR")) D
. S XMDUN="HDI SDO Order Server",XMDUZ=".5"
. S XMSUB=HDISTN_" HDI SDO ORDER SERVER ERROR ("_HDINOW_")"
. S XMTEXT="^TMP($J,""HDIDTERR"","
. S XMY(XQSND)=""
. D ^XMD
;
; Clean up server message in MailMan
I $G(HDIXMZ)>0 D ZAPSERV^XMXAPI("S.HDISDOSERVER",HDIXMZ)
;
K %,%DT,%H,D,DD,DIC,DIERR,ERROR,FILL,LINE,LOINCDTA,LOINCDTB,LOINCTAS
K HDIA,HDIAA,HDIACTON,HDIB,HDICLST,HDIDA,HDIERR,HDIFOUND,HDIFOUND1,HDII,HDILINE
K HDINDE,HDIOUT,HDIPNT,HDIPNTA,HDIPNTB,HDIRDT,HDIRN,HDIROOT,HDIST,HDISTN,HDISUB
K X,XMDUN,XMDUZ,XMER,XMFROM,XMREC,XMRG,XMSUB,XMTEXT,XMY,XMZ,XQDATE,HDINODE
K XQSND,XQSUB,Y,ZTQUEUED,ZTSK,HDICRLF,HDIJB,HDILEN,HDIMSUBJ,HDIQUIT,HDITXT
K HDIMAX
;
K ^TMP($J,"HDIDATA"),^TMP($J,"HDIDTERR")
S:$D(ZTQUEUED) ZTREQ="@"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHDISDSR 2649 printed Nov 22, 2024@17:06:42 Page 2
HDISDSR ;BPFO/DTG - HDI MAILMAN SERVER FOR COLLECTING SDO; Apr 07, 2018@12:42
+1 ;;1.0;HEALTH DATA & INFORMATICS;**22**;Feb 22, 2005;Build 26
+2 ;
START ;
+1 NEW A,HDISITE,HDIST,HDISUB,HDIXMZ,HDISV,HDER,HDICRLF,HDIJB,HDILEN,HDIMSUBJ,HDIQUIT,HDITXT,HDINODE
+2 NEW HDIMAX
+3 ;
+4 ; Save incoming server message id for cleanup
+5 SET HDIXMZ=XMZ
+6 ;
+7 SET HDISV="^TMP($J,""HDIDATA"")"
SET HDER="^TMP($J,""HDIDTERR"")"
+8 KILL @HDISV,@HDER
+9 ; Determine station name and number
+10 SET HDISITE=$$SITE^VASITE
SET HDISTN=$PIECE(HDISITE,"^",2)
SET HDIST=$PIECE(HDISITE,"^",3)
+11 IF HDIST=""
SET HDIST="???"
+12 ;
+13 SET HDISUB=$$UP^XLFSTR(XQSUB)
+14 ;
+15 ; The first line of the message tells who requested the action and when
+16 ; The second line tells when the server is activated and no data can be
+17 ; gathered from the MailMan message. This line gets replaced if the
+18 ; server finds something to do.
+19 SET A="SDO lookup option: "_HDISUB_$JUSTIFY(" ",6)
+20 SET ^TMP($JOB,"HDIDATA",1)=A
+21 SET A="Was triggered at "_HDISTN_" by "_XMFROM_" on "_XQDATE_$JUSTIFY(" ",6)
+22 SET ^TMP($JOB,"HDIDATA",2)=A
+23 SET ^TMP($JOB,"HDIDATA",3)=" "_$JUSTIFY(" ",6)
+24 SET HDIACTON=HDISUB
+25 SET A="This SDO lookup option: "_HDIACTON_$JUSTIFY(" ",6)
+26 SET ^TMP($JOB,"HDIDATA",4)=A
+27 SET A="Is NOT available at "_HDISTN_$JUSTIFY(" ",6)
+28 SET ^TMP($JOB,"HDIDATA",5)=A
+29 SET A=""
+30 ;
+31 ;
+32 IF HDISUB="LAB"
DO EN1^HDISDSRL
QUIT
+33 ;
+34 ; If subject not understood by server, send a message to the sender
+35 ; that the server can't understand their instructions.
+36 KILL XMY
+37 SET XMY(XQSND)=""
+38 ;
EXIT ; If all went well, report that too.
+1 ; Mail the errors and successes back to the Roll-Up group at Forum.
+2 NEW HDINOW
+3 SET HDINOW=$$NOW^XLFDT
SET A=$$FMTE^XLFDT(HDINOW,5)
+4 SET XMDUN="HDI SDO Server"
SET XMDUZ=".5"
SET XMSUB=HDISTN_" HDI SDO SERVER ("_A_" ["_HDINOW_"])"
+5 KILL XMTEXT
SET XMTEXT="^TMP($J,""HDIDATA"","
+6 IF '$DATA(XMY)
SET XMY($GET(XQSND))=""
+7 NEW DIFROM
DO ^XMD
KILL DIFROM
+8 ;
CLEAN ; Cleanup and exit
+1 IF $DATA(^TMP($JOB,"HDIDTERR"))
Begin DoDot:1
+2 SET XMDUN="HDI SDO Order Server"
SET XMDUZ=".5"
+3 SET XMSUB=HDISTN_" HDI SDO ORDER SERVER ERROR ("_HDINOW_")"
+4 SET XMTEXT="^TMP($J,""HDIDTERR"","
+5 SET XMY(XQSND)=""
+6 DO ^XMD
End DoDot:1
+7 ;
+8 ; Clean up server message in MailMan
+9 IF $GET(HDIXMZ)>0
DO ZAPSERV^XMXAPI("S.HDISDOSERVER",HDIXMZ)
+10 ;
+11 KILL %,%DT,%H,D,DD,DIC,DIERR,ERROR,FILL,LINE,LOINCDTA,LOINCDTB,LOINCTAS
+12 KILL HDIA,HDIAA,HDIACTON,HDIB,HDICLST,HDIDA,HDIERR,HDIFOUND,HDIFOUND1,HDII,HDILINE
+13 KILL HDINDE,HDIOUT,HDIPNT,HDIPNTA,HDIPNTB,HDIRDT,HDIRN,HDIROOT,HDIST,HDISTN,HDISUB
+14 KILL X,XMDUN,XMDUZ,XMER,XMFROM,XMREC,XMRG,XMSUB,XMTEXT,XMY,XMZ,XQDATE,HDINODE
+15 KILL XQSND,XQSUB,Y,ZTQUEUED,ZTSK,HDICRLF,HDIJB,HDILEN,HDIMSUBJ,HDIQUIT,HDITXT
+16 KILL HDIMAX
+17 ;
+18 KILL ^TMP($JOB,"HDIDATA"),^TMP($JOB,"HDIDTERR")
+19 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+20 QUIT
