DG53244P ;BPFO/JRP - Post init for DG*5.3*244 ; 26 Jan 2002 10:51 PM
;;5.3;Registration;**244**;Aug 13, 1993
;
POST ;Entry point for post init
D POST^DG53244S
D HL7
Q
;
HL7 ;BPFO/JRP - Set up scratch HL7 protocol used for delivery of name
; change messages to local COTS systems (mimic ADT-A08 messaging in
; VAFC namespace)
;
D BMES^XPDUTL("Building HL7 protocol...")
;Declare/initialize variables
N IGNORE,LOCAL,WHOOPS,PTR101,ORIGNAME,NEWNAME,TEXT
S ORIGNAME="VAFC ADT-A08 SERVER"
S NEWNAME="DG PATCH 244"
S TEXT(1)=" "
S TEXT(2)="Adding local subscribers of the '"_ORIGNAME_"' protocol"
S TEXT(3)="as subscribers to the '"_NEWNAME_"' protocol. Doing"
S TEXT(4)="this will allow COTS systems to be notified of name changes"
S TEXT(5)="made during the name standardization conversion."
S TEXT(6)=" "
D MES^XPDUTL(.TEXT)
;Get list of subscribers to ignore
K TEXT
S TEXT(1)=" "
S TEXT(2)="Building list of national subscribers to exclude ..."
D MES^XPDUTL(.TEXT)
D BLDIGN(.IGNORE)
;Get subscription list of original event protocol
K TEXT
S TEXT(1)=" "
S TEXT(2)="Building list of local subscribers to '"_ORIGNAME_"' ..."
D MES^XPDUTL(.TEXT)
S PTR101=$$FIND1^DIC(101,,"QX",ORIGNAME,"B")
I 'PTR101 D Q
.D CLEAN^DILF
.K TEXT
.S TEXT(1)=" "
.S TEXT(2)=" "
.S TEXT(3)=" ** ERROR **"
.S TEXT(4)=" Protocol '"_ORIGNAME_"' could not be found"
.S TEXT(5)=" ***********"
.S TEXT(6)=" "
.S TEXT(7)="** Resolve error and run HL7^DG53244P before running name conversion **"
.S TEXT(8)=" "
.S TEXT(9)="--------------------"
.D MES^XPDUTL(.TEXT)
D BLDCUR(PTR101,.LOCAL,.IGNORE)
;No local protocols
I '$O(LOCAL(0)) D Q
.K TEXT
.S TEXT(1)=" "
.S TEXT(2)="No local subscribers where found. No further actions required."
.S TEXT(3)=" "
.S TEXT(4)="--------------------"
.D MES^XPDUTL(.TEXT)
;Add local protocols as subscribers to conversion protocol
K TEXT
S TEXT(1)=" "
S TEXT(2)="Adding local subscribers to '"_NEWNAME_"' ..."
D MES^XPDUTL(.TEXT)
S PTR101=$$FIND1^DIC(101,,"QX",NEWNAME,"B")
I 'PTR101 D Q
.D CLEAN^DILF
.K TEXT
.S TEXT(1)=" "
.S TEXT(2)=" "
.S TEXT(3)=" ** ERROR **"
.S TEXT(4)=" Protocol '"_NEWNAME_"' could not be found"
.S TEXT(5)=" ***********"
.S TEXT(6)=" "
.S TEXT(7)="** Resolve error and run HL7^DG53244P before running name conversion **"
.S TEXT(8)=" "
.S TEXT(9)="--------------------"
.D MES^XPDUTL(.TEXT)
D ADDLIST(PTR101,.LOCAL,.WHOOPS)
;Not all protocol were added
I +$O(WHOOPS(0)) D Q
.;Print error(s)
.K TEXT
.S TEXT(1)=" "
.S TEXT(2)=" ** ERROR **"
.S TEXT(3)=" The following protocols were not added as subscribers"
.D MES^XPDUTL(.TEXT)
.S PTR101=0
.F S PTR101=+$O(WHOOPS(PTR101)) Q:'PTR101 D
..K TEXT
..S TEXT=" "_WHOOPS(PTR101)
..D MES^XPDUTL(TEXT)
.K TEXT
.S TEXT(1)=" ***********"
.S TEXT(2)=" "
.S TEXT(3)="** Resolve error and run HL7^DG53244P before running name conversion **"
.S TEXT(4)=" "
.S TEXT(5)="--------------------"
.D MES^XPDUTL(.TEXT)
;Done
D BMES^XPDUTL("--------------------")
Q
;
BLDIGN(ARRAY) ;Build list of HL7 subscriber protocols to ignore
;Input : ARRAY - Array to place list into (dot syntax)
;Output : ARRAY() - List of HL7 subscriber protocols to ignore
; ARRAY(x) = Protocol Name
; x is pointer to Protocol file
;Note : Assumes ARRAY was input
; : ARRAY is initialized (KILLed) on input
;
;Declare variables
N LINE,TEXT,PTR101
K ARRAY
;Loop though list of names
F LINE=1:1 S TEXT=$T(IGNORE+LINE) Q:$P(TEXT,";",2) D
.S TEXT=$P(TEXT,";",3,99999)
.Q:TEXT=""
.;Convert name to pointer
.S PTR101=$$FIND1^DIC(101,,"QX",TEXT,"B")
.Q:'PTR101
.;Add to list
.S ARRAY(PTR101)=TEXT
;Done
D CLEAN^DILF
Q
;
BLDCUR(EVENT,ARRAY,EXCEPT) ;Build list of subscribers to HL7 event protocol
;Input : EVENT - Pointer to event protocol
; ARRAY - Array to place list into (dot syntax)
; EXCEPT - List of subscribers to exclude (optional)(dot syntax)
; EXCEPT(x) where x is pointer to Protocol file
;Output : ARRAY() - List of subscribing protocols
; ARRAY(x) = Protocol Name
; x is pointer to Protocol file
;Note : Assumes EVENT & ARRAY are input
; : Assumes EVENT is a valid pointer to an HL7 event protocol
; : ARRAY is initialized (KILLed on input)
;
;Declare variables
N PTR101,NODE,IENS,PTRMULT,ITEM,SUBSCRIB
K ARRAY
;Get entries in ITEM and SUBSCRIBER multiples
S IENS=","_EVENT_","
D LIST^DIC(101.01,IENS,.01,"I",,,,,,,"ITEM")
D LIST^DIC(101.0775,IENS,.01,"I",,,,,,,"SUBSCRIB")
D CLEAN^DILF
;Empty multiples
Q:'$G(ITEM("DILIST",0))
Q:'$G(SUBSCRIB("DILIST",0))
;Loop extracted lists
F NODE=$NA(ITEM("DILIST",1)),$NA(SUBSCRIB("DILIST",1)) D
.S PTRMULT=0
.F S PTRMULT=+$O(@NODE@(PTRMULT)) Q:'PTRMULT D
..S PTR101=+$G(@NODE@(PTRMULT))
..Q:'PTR101
..;Screen out excluded protocols
..Q:$D(EXCEPT(PTR101))
..;Already in list
..Q:$D(ARRAY(PTR101))
..;Add to output list
..S IENS=PTR101_","
..S ARRAY(PTR101)=$$GET1^DIQ(101,PTR101,.01)
;Done
D CLEAN^DILF
Q
;
ADDLIST(EVENT,ARRAY,ERROR) ;Add subscribers to HL7 event protocol
;Input : EVENT - Pointer to event protocol
; ARRAY - List of subscribing protocols (dot syntax)
; ARRAY(x) = Protocol Name
; x is pointer to Protocol file
; ERROR - Array to contain list of protocols that could not
; be added as subscribers (dot syntax)
;Output : None
; ERROR() - List of non-added protocols
; ERROR(x) = Protocol name
; x is pointer to Protocol file
;Note : Assumes EVENT, ARRAY, and ERROR are input
; : Assumes EVENT is a valid pointer to an HL7 event protocol
; : Assumes ARRAY contains valid pointers to HL7 subscriber
; protocols
;
;Declare variables
N IENS,FDAROOT,IENROOT,MSGROOT,PTR101
;Loop through list of subscribers
S PTR101=0
F S PTR101=+$O(ARRAY(PTR101)) Q:'PTR101 D
.;Add protocol to subscription list of event protocol
.K FDAROOT,IENROOT,MSGROOT
.S IENS="?+1,"_EVENT_","
.S FDAROOT(101.0775,IENS,.01)=PTR101
.D UPDATE^DIE("","FDAROOT","IENROOT","MSGROOT")
.I $D(MSGROOT("DIERR")) S ERROR(PTR101)=ARRAY(PTR101)
;Done
D CLEAN^DILF
Q
;
;
IGNORE ;List of National HL7 subscriber protocols to ignore
;;DG PTF ADT-A08 CLIENT
;;VAFC TFL-UPDATE CLIENT
;;RG ADT-A08 CLIENT
;;RG PT SUBSCRIPTION RECEIVER
;1;End of list
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53244P 6728 printed Dec 13, 2024@02:36:50 Page 2
DG53244P ;BPFO/JRP - Post init for DG*5.3*244 ; 26 Jan 2002 10:51 PM
+1 ;;5.3;Registration;**244**;Aug 13, 1993
+2 ;
POST ;Entry point for post init
+1 DO POST^DG53244S
+2 DO HL7
+3 QUIT
+4 ;
HL7 ;BPFO/JRP - Set up scratch HL7 protocol used for delivery of name
+1 ; change messages to local COTS systems (mimic ADT-A08 messaging in
+2 ; VAFC namespace)
+3 ;
+4 DO BMES^XPDUTL("Building HL7 protocol...")
+5 ;Declare/initialize variables
+6 NEW IGNORE,LOCAL,WHOOPS,PTR101,ORIGNAME,NEWNAME,TEXT
+7 SET ORIGNAME="VAFC ADT-A08 SERVER"
+8 SET NEWNAME="DG PATCH 244"
+9 SET TEXT(1)=" "
+10 SET TEXT(2)="Adding local subscribers of the '"_ORIGNAME_"' protocol"
+11 SET TEXT(3)="as subscribers to the '"_NEWNAME_"' protocol. Doing"
+12 SET TEXT(4)="this will allow COTS systems to be notified of name changes"
+13 SET TEXT(5)="made during the name standardization conversion."
+14 SET TEXT(6)=" "
+15 DO MES^XPDUTL(.TEXT)
+16 ;Get list of subscribers to ignore
+17 KILL TEXT
+18 SET TEXT(1)=" "
+19 SET TEXT(2)="Building list of national subscribers to exclude ..."
+20 DO MES^XPDUTL(.TEXT)
+21 DO BLDIGN(.IGNORE)
+22 ;Get subscription list of original event protocol
+23 KILL TEXT
+24 SET TEXT(1)=" "
+25 SET TEXT(2)="Building list of local subscribers to '"_ORIGNAME_"' ..."
+26 DO MES^XPDUTL(.TEXT)
+27 SET PTR101=$$FIND1^DIC(101,,"QX",ORIGNAME,"B")
+28 IF 'PTR101
Begin DoDot:1
+29 DO CLEAN^DILF
+30 KILL TEXT
+31 SET TEXT(1)=" "
+32 SET TEXT(2)=" "
+33 SET TEXT(3)=" ** ERROR **"
+34 SET TEXT(4)=" Protocol '"_ORIGNAME_"' could not be found"
+35 SET TEXT(5)=" ***********"
+36 SET TEXT(6)=" "
+37 SET TEXT(7)="** Resolve error and run HL7^DG53244P before running name conversion **"
+38 SET TEXT(8)=" "
+39 SET TEXT(9)="--------------------"
+40 DO MES^XPDUTL(.TEXT)
End DoDot:1
QUIT
+41 DO BLDCUR(PTR101,.LOCAL,.IGNORE)
+42 ;No local protocols
+43 IF '$ORDER(LOCAL(0))
Begin DoDot:1
+44 KILL TEXT
+45 SET TEXT(1)=" "
+46 SET TEXT(2)="No local subscribers where found. No further actions required."
+47 SET TEXT(3)=" "
+48 SET TEXT(4)="--------------------"
+49 DO MES^XPDUTL(.TEXT)
End DoDot:1
QUIT
+50 ;Add local protocols as subscribers to conversion protocol
+51 KILL TEXT
+52 SET TEXT(1)=" "
+53 SET TEXT(2)="Adding local subscribers to '"_NEWNAME_"' ..."
+54 DO MES^XPDUTL(.TEXT)
+55 SET PTR101=$$FIND1^DIC(101,,"QX",NEWNAME,"B")
+56 IF 'PTR101
Begin DoDot:1
+57 DO CLEAN^DILF
+58 KILL TEXT
+59 SET TEXT(1)=" "
+60 SET TEXT(2)=" "
+61 SET TEXT(3)=" ** ERROR **"
+62 SET TEXT(4)=" Protocol '"_NEWNAME_"' could not be found"
+63 SET TEXT(5)=" ***********"
+64 SET TEXT(6)=" "
+65 SET TEXT(7)="** Resolve error and run HL7^DG53244P before running name conversion **"
+66 SET TEXT(8)=" "
+67 SET TEXT(9)="--------------------"
+68 DO MES^XPDUTL(.TEXT)
End DoDot:1
QUIT
+69 DO ADDLIST(PTR101,.LOCAL,.WHOOPS)
+70 ;Not all protocol were added
+71 IF +$ORDER(WHOOPS(0))
Begin DoDot:1
+72 ;Print error(s)
+73 KILL TEXT
+74 SET TEXT(1)=" "
+75 SET TEXT(2)=" ** ERROR **"
+76 SET TEXT(3)=" The following protocols were not added as subscribers"
+77 DO MES^XPDUTL(.TEXT)
+78 SET PTR101=0
+79 FOR
SET PTR101=+$ORDER(WHOOPS(PTR101))
if 'PTR101
QUIT
Begin DoDot:2
+80 KILL TEXT
+81 SET TEXT=" "_WHOOPS(PTR101)
+82 DO MES^XPDUTL(TEXT)
End DoDot:2
+83 KILL TEXT
+84 SET TEXT(1)=" ***********"
+85 SET TEXT(2)=" "
+86 SET TEXT(3)="** Resolve error and run HL7^DG53244P before running name conversion **"
+87 SET TEXT(4)=" "
+88 SET TEXT(5)="--------------------"
+89 DO MES^XPDUTL(.TEXT)
End DoDot:1
QUIT
+90 ;Done
+91 DO BMES^XPDUTL("--------------------")
+92 QUIT
+93 ;
BLDIGN(ARRAY) ;Build list of HL7 subscriber protocols to ignore
+1 ;Input : ARRAY - Array to place list into (dot syntax)
+2 ;Output : ARRAY() - List of HL7 subscriber protocols to ignore
+3 ; ARRAY(x) = Protocol Name
+4 ; x is pointer to Protocol file
+5 ;Note : Assumes ARRAY was input
+6 ; : ARRAY is initialized (KILLed) on input
+7 ;
+8 ;Declare variables
+9 NEW LINE,TEXT,PTR101
+10 KILL ARRAY
+11 ;Loop though list of names
+12 FOR LINE=1:1
SET TEXT=$TEXT(IGNORE+LINE)
if $PIECE(TEXT,";",2)
QUIT
Begin DoDot:1
+13 SET TEXT=$PIECE(TEXT,";",3,99999)
+14 if TEXT=""
QUIT
+15 ;Convert name to pointer
+16 SET PTR101=$$FIND1^DIC(101,,"QX",TEXT,"B")
+17 if 'PTR101
QUIT
+18 ;Add to list
+19 SET ARRAY(PTR101)=TEXT
End DoDot:1
+20 ;Done
+21 DO CLEAN^DILF
+22 QUIT
+23 ;
BLDCUR(EVENT,ARRAY,EXCEPT) ;Build list of subscribers to HL7 event protocol
+1 ;Input : EVENT - Pointer to event protocol
+2 ; ARRAY - Array to place list into (dot syntax)
+3 ; EXCEPT - List of subscribers to exclude (optional)(dot syntax)
+4 ; EXCEPT(x) where x is pointer to Protocol file
+5 ;Output : ARRAY() - List of subscribing protocols
+6 ; ARRAY(x) = Protocol Name
+7 ; x is pointer to Protocol file
+8 ;Note : Assumes EVENT & ARRAY are input
+9 ; : Assumes EVENT is a valid pointer to an HL7 event protocol
+10 ; : ARRAY is initialized (KILLed on input)
+11 ;
+12 ;Declare variables
+13 NEW PTR101,NODE,IENS,PTRMULT,ITEM,SUBSCRIB
+14 KILL ARRAY
+15 ;Get entries in ITEM and SUBSCRIBER multiples
+16 SET IENS=","_EVENT_","
+17 DO LIST^DIC(101.01,IENS,.01,"I",,,,,,,"ITEM")
+18 DO LIST^DIC(101.0775,IENS,.01,"I",,,,,,,"SUBSCRIB")
+19 DO CLEAN^DILF
+20 ;Empty multiples
+21 if '$GET(ITEM("DILIST",0))
QUIT
+22 if '$GET(SUBSCRIB("DILIST",0))
QUIT
+23 ;Loop extracted lists
+24 FOR NODE=$NAME(ITEM("DILIST",1)),$NAME(SUBSCRIB("DILIST",1))
Begin DoDot:1
+25 SET PTRMULT=0
+26 FOR
SET PTRMULT=+$ORDER(@NODE@(PTRMULT))
if 'PTRMULT
QUIT
Begin DoDot:2
+27 SET PTR101=+$GET(@NODE@(PTRMULT))
+28 if 'PTR101
QUIT
+29 ;Screen out excluded protocols
+30 if $DATA(EXCEPT(PTR101))
QUIT
+31 ;Already in list
+32 if $DATA(ARRAY(PTR101))
QUIT
+33 ;Add to output list
+34 SET IENS=PTR101_","
+35 SET ARRAY(PTR101)=$$GET1^DIQ(101,PTR101,.01)
End DoDot:2
End DoDot:1
+36 ;Done
+37 DO CLEAN^DILF
+38 QUIT
+39 ;
ADDLIST(EVENT,ARRAY,ERROR) ;Add subscribers to HL7 event protocol
+1 ;Input : EVENT - Pointer to event protocol
+2 ; ARRAY - List of subscribing protocols (dot syntax)
+3 ; ARRAY(x) = Protocol Name
+4 ; x is pointer to Protocol file
+5 ; ERROR - Array to contain list of protocols that could not
+6 ; be added as subscribers (dot syntax)
+7 ;Output : None
+8 ; ERROR() - List of non-added protocols
+9 ; ERROR(x) = Protocol name
+10 ; x is pointer to Protocol file
+11 ;Note : Assumes EVENT, ARRAY, and ERROR are input
+12 ; : Assumes EVENT is a valid pointer to an HL7 event protocol
+13 ; : Assumes ARRAY contains valid pointers to HL7 subscriber
+14 ; protocols
+15 ;
+16 ;Declare variables
+17 NEW IENS,FDAROOT,IENROOT,MSGROOT,PTR101
+18 ;Loop through list of subscribers
+19 SET PTR101=0
+20 FOR
SET PTR101=+$ORDER(ARRAY(PTR101))
if 'PTR101
QUIT
Begin DoDot:1
+21 ;Add protocol to subscription list of event protocol
+22 KILL FDAROOT,IENROOT,MSGROOT
+23 SET IENS="?+1,"_EVENT_","
+24 SET FDAROOT(101.0775,IENS,.01)=PTR101
+25 DO UPDATE^DIE("","FDAROOT","IENROOT","MSGROOT")
+26 IF $DATA(MSGROOT("DIERR"))
SET ERROR(PTR101)=ARRAY(PTR101)
End DoDot:1
+27 ;Done
+28 DO CLEAN^DILF
+29 QUIT
+30 ;
+31 ;
IGNORE ;List of National HL7 subscriber protocols to ignore
+1 ;;DG PTF ADT-A08 CLIENT
+2 ;;VAFC TFL-UPDATE CLIENT
+3 ;;RG ADT-A08 CLIENT
+4 ;;RG PT SUBSCRIPTION RECEIVER
+5 ;1;End of list
+6 ;
