DG53190T ; ALB/SCK - UTILITY TO CREATE RAI/MDS SUBSCRIBER PROTOCOLS ; 10-14-99
;;5.3;Registration;**190,357,416,1015**;Aug 13, 1993;Build 21
;
EN ;
N DGSTN,FDA,DIR,ERR,HLLP,DGDIV,DGSCN,DGTEST,DGX,DGABRT,HLAPP,HLLINK,DGABRT,I,X,Y,DGIP,DGPORT
;
W @IOF
F I=0:1 S DGX=$P($T(TEXT+I),";;",2) Q:DGX="$END" W !,DGX
S DIR(0)="YA",DIR("B")="NO",DIR("A")="Do you wish to continue? "
S DIR("?")="Enter Yes to continue, or No to quit"
D ^DIR K DIR
Q:'Y!$D(DIRUT)
;
F DGX="DIV","SETIP","870","771","408","101","DEM","MFU","FIN" D @DGX Q:$G(DGABRT)
Q
;
DIV ;
W !
N DIR,DIRUT
S DIR(0)="PO^40.8:EMZ"
S DIR("A",1)="Enter the Division you are setting up the"
S DIR("A")="RAI/MDS HL7 messaging for"
S DIR("?")="Select the appropriate division to set up the HL7 messaging parameters for."
D ^DIR K DIR I $D(DIRUT)!(+Y'>0) S DGABRT=1 Q
S DGDIV=Y
S DGSTN=$$SITE^VASITE($$NOW^XLFDT,+DGDIV)
;
W !!?4,"You have selected : ",$P(DGDIV,"^",2)
W !?4,"Station Number : ",$S(+DGSTN>0:$P(DGSTN,"^",3),1:"Undefined Station Number"),!
;
I +DGSTN<0 D G DIV
. W !?4,"You cannot proceed with this division until the station number is"
. W !?4,"corrected. Check the STATION NUMBER TIME SENSITIVE"
. W !?4,"file to be sure this division is active today."
. W !?4,"You may select another division or quit.",!
;
N DIR,DUOUT,DTOUT
;
S DIR(0)="YAO",DIR("A")="Is this correct? ",DIR("B")="YES"
S DIR("?")="Enter Yes or No, Yes will select, No will cancel."
D ^DIR K DIR Q:$D(DUOUT)!($D(DTOUT))
G:'Y DIV
W !
Q
;
SETIP ; Get IP address and port number
N ERR,RSLT,FDA,DIR,DIRUT
;
IP S DIR(0)="FAO",DIR("A")="Enter IP address of target COTS receiver: "
S DIR("?",1)="The IP address must be in the format 'nnn.nnn.nnn.nnn' where"
S DIR("?",2)="nnn is a numeric, 1-3 numbers in length and should designate"
S DIR("?")="the static IP address for the COTS database server."
D ^DIR K DIR
Q:$D(DIRUT)
;
G:$P(Y,".",1)'?1.3N IP
G:$P(Y,".",2)'?1.3N IP
G:$P(Y,".",3)'?1.3N IP
G:$P(Y,".",4)'?1.3N IP
S DGIP=$G(Y)
PORT ;
N DIR
S DIR(0)="FAO",DIR("A")="Enter the port number of the target COTS receiver: "
S DIR("?",1)="The port number must be a numeric value and should be"
S DIR("?")="the TCP/IP port the target COTS receiver is listening on."
D ^DIR K DIR
Q:$D(DIRUT)
;
G:Y'?1N.N PORT
S DGPORT=$G(Y)
Q
;
870 ; Create HL7 Logical Link
N ERR,RSLT,FDA,DGLLP,DGLNK
;
S DGLNK="DGRU"_$P(DGSTN,"^",3) ; Check for existing Logical Link
I $$FIND1^DIC(870,"","MX",DGLNK)>0 D Q
. W !?4,"A Logical Link for ",DGLNK," already exists."
;
; Set up the logical link
K FDA
S FDA(1,870,"+1,",.01)=DGLNK
S FDA(1,870,"+1,",4.5)=1
S FDA(1,870,"+1,",2)="TCP"
S FDA(1,870,"+1,",3)="NC" ;p-416
S FDA(1,870,"+1,",200.021)="R" ;added p-416
S FDA(1,870,"+1,",200.05)=20
S FDA(1,870,"+1,",200.08)=2.3
S FDA(1,870,"+1,",400.01)=DGIP
S FDA(1,870,"+1,",400.02)=DGPORT
S FDA(1,870,"+1,",400.03)="C"
S FDA(1,870,"+1,",400.04)="N" ;p-416
;
D UPDATE^DIE("E","FDA(1)","RSLT","ERR(1)")
I $D(ERR) D Q
. W !,DGLNK,": " D MSG^DIALOG("WM","","",4,"ERR(1)")
. S DGABRT=1
S HLLINK=RSLT(1)
Q
;
771 ; Create HL7 application
N ERR,RSLT,FDA,DGNAME
;
; Retrieve ien of HL7 messaging mail group
S DIC=3.8,DIC(0)="MZ",X="DGRU ADT/HL7"
D ^DIC K DIC
S DGMAIL=$G(Y(0,0))
;
K FDA
S DGNAME="DGRU-"_$P(DGSTN,"^",2)
S:$L(DGNAME)>15 DGNAME=$E(DGNAME,1,15)
; Check for existing HL7 Application
S HLAPP=$$FIND1^DIC(771,"","MX",DGNAME) I HLAPP>0 D Q ;p-416
. W !?4,"A HL7 Application for ",DGNAME," already exists."
;
S FDA(1,771,"+1,",.01)=DGNAME
S FDA(1,771,"+1,",3)=$P(DGSTN,"^",3)
S FDA(1,771,"+1,",4)=DGMAIL
S FDA(1,771,"+1,",7)="USA"
;
D UPDATE^DIE("E","FDA(1)","RSLT","ERR(1)")
I $D(ERR) D Q
. W !,DGNAME,": " D MSG^DIALOG("WM","","",4,"ERR(1)")
. S DGABRT=1
S HLAPP=RSLT(1)
Q
;
408 ; Create subscription registry entry
N ERR,RSLT,FDA,DGSCN,DGLL,DGAP
;
S DGSCN=$$ACT^HLSUB
I '$D(HLAPP)!('$D(HLLINK)) D Q
. W !?4,"HL7 Application data not available"
;
S DGLL=$$GET1^DIQ(870,HLLINK,.01)
S DGAP=$$GET1^DIQ(771,HLAPP,.01)
;
D UPD^HLSUB(DGSCN,DGLL,2,,,DGAP,.ERR)
I $D(ERR) D Q
. W !,DGSCN,": " D MSG^DIALOG("WM","","",4,"ERR(1)")
. S DGABRT=1
;
S FDA(1,40.8,+DGDIV_",",900.01)=DGSCN
;
K ERR D FILE^DIE("","FDA(1)","ERR")
I $D(ERR) D
. W ! D MSG^DIALOG("WM","","",4,"ERR(1)")
. S DGABRT=1
Q
;
101 ; Create subscriber protocols
N EVNT,FDA,ERR,RSLT,DGNAME,IEN,DGCLIENT
;
S IEN=0
F EVNT="A01","A02","A03","A11","A12","A13","A21","A22","A08" D Q:$G(DGABRT)
. S IEN=IEN+1
. S DGNAME="DGRU-RAI-"_EVNT_"-"_HLAPP ;changed p-357
. ;Check for existing protocol
. I $$FIND1^DIC(101,"","MX",DGNAME)>0 D Q
. . W !?4,"A protocol for ",DGNAME," already exists."
. ;
. S FDA(1,101,"+"_IEN_",",.01)=DGNAME
. S FDA(1,101,"+"_IEN_",",1)=EVNT_" CLIENT PROTOCOL FOR "_$P(DGSTN,"^",2)
. S FDA(1,101,"+"_IEN_",",4)="subscriber"
. S FDA(1,101,"+"_IEN_",",12)="REGISTRATION"
. S DGCLIENT="DGRU-"_$P(DGSTN,"^",2)
. S:$L(DGCLIENT)>15 DGCLIENT=$E(DGCLIENT,1,15)
. S FDA(1,101,"+"_IEN_",",770.2)=DGCLIENT
. S FDA(1,101,"+"_IEN_",",770.3)="ADT"
. S FDA(1,101,"+"_IEN_",",770.4)=EVNT
. S FDA(1,101,"+"_IEN_",",770.7)="DGRU"_$P(DGSTN,"^",3)
. S FDA(1,101,"+"_IEN_",",770.11)="ADT"
. S FDA(1,101,"+"_IEN_",",771)="Q"
. S FDA(1,101,"+"_IEN_",",773.1)="YES"
. S FDA(1,101,"+"_IEN_",",773.2)="YES"
. K ERR,RSLT
. D UPDATE^DIE("E","FDA(1)","RSLT","ERR(1)")
. I +$G(RSLT(IEN))>0 D
. . S DIE=101,DR="770.95////2.3",DA=RSLT(IEN) D ^DIE K DIE
. I $D(ERR) D
.. W ! D MSG^DIALOG("WM","","",4,"ERR(1)")
.. S DGABRT=1
Q
;
DEM ;
N FDA,RSLT,ERR,DGNAME,DGCLIENT,DGTXT
;
S DGNAME="DGRU-PATIENT-A08-"_HLAPP ;changed p-357
S FDA(1,101,"+1,",.01)=DGNAME
; Check for existing protocol
I $$FIND1^DIC(101,"","MX",DGNAME)>0 D Q
. W !?4,"A protocol for ",DGNAME," already exists."
;
S DGTXT="A08 DEMOGRAPHIC UPDATES CLIENT PROTOCOL FOR "_$P(DGSTN,"^",2)
S:$L(DGTXT)>62 DGTXT=$E(DGTXT,1,62)
S FDA(1,101,"+1,",1)=DGTXT
S FDA(1,101,"+1,",4)="subscriber"
S FDA(1,101,"+1,",12)="REGISTRATION"
S DGCLIENT="DGRU-"_$P(DGSTN,"^",2)
S:$L(DGCLIENT)>15 DGCLIENT=$E(DGCLIENT,1,15)
S FDA(1,101,"+1,",770.2)=DGCLIENT
S FDA(1,101,"+1,",770.3)="ADT"
S FDA(1,101,"+1,",770.4)="A08"
S FDA(1,101,"+1,",770.7)="DGRU"_$P(DGSTN,"^",3)
S FDA(1,101,"+1,",770.11)="ADT"
S FDA(1,101,"+1,",771)="Q"
S FDA(1,101,"+1,",773.1)="YES"
S FDA(1,101,"+1,",773.2)="YES"
K ERR,RSLT
D UPDATE^DIE("E","FDA(1)","RSLT","ERR(1)")
I $D(ERR) D Q
. W ! D MSG^DIALOG("WM","","",4,"ERR(1)")
. S DGABRT=1
;
I +$G(RSLT(1))>0 D
. S DIE=101,DR="770.95////2.3",DA=RSLT(1) D ^DIE K DIE
Q
;
MFU ;
N FDA,RSLT,ERR,DGNAME,DGCLIENT,DGTXT
S DGNAME="DGRU-RAI-MFU-"_HLAPP
; Check for existing protocol
I $$FIND1^DIC(101,"","MX",DGNAME)>0 D Q
. W !?4,"A protocol for ",DGNAME," already exists."
;
S FDA(1,101,"+1,",.01)=DGNAME
S DGTXT="MFU CLIENT PROTOCOL FOR "_$P(DGSTN,"^",2)
S:$L(DGTXT)>62 DGTXT=$E(DGTXT,1,62)
S FDA(1,101,"+1,",1)=DGTXT
S FDA(1,101,"+1,",4)="subscriber"
S FDA(1,101,"+1,",12)="REGISTRATION"
S DGCLIENT="DGRU-"_$P(DGSTN,"^",2)
S:$L(DGCLIENT)>15 DGCLIENT=$E(DGCLIENT,1,15)
S FDA(1,101,"+1,",770.2)=DGCLIENT
S FDA(1,101,"+1,",770.3)="MFN"
S FDA(1,101,"+1,",770.4)="M01"
S FDA(1,101,"+1,",770.7)="DGRU"_$P(DGSTN,"^",3)
S FDA(1,101,"+1,",770.11)="MFN"
S FDA(1,101,"+1,",771)="Q"
S FDA(1,101,"+1,",773.1)="YES"
S FDA(1,101,"+1,",773.2)="YES"
K ERR,RSLT
D UPDATE^DIE("E","FDA(1)","RSLT","ERR(1)")
I $D(ERR) D Q
.W ! D MSG^DIALOG("WM","","",4,"ERR(1)")
.S DGABRT=1
I +$G(RSLT(1))>0 D
.S DIE=101,DR="770.95////^S X=2.3",DA=RSLT(1) D ^DIE K DIE
Q
;
FIN ;
W !!?4,"Setup complete"
Q
;
TEXT ;;This routine will setup the necessary HL7 messaging parameters and client
;;protocols for the selected division for the RAI/MDS Commercial-Off-The-Shelf
;;system. This is required in order to correctly handle the dynamic addressing
;;used by VistA to process HL7 messages to the COTS system.
;;
;;THIS ROUTINE SHOULD ONLY BE EXECUTED WHEN NEW DIVISIONS USING RAI/MDS NEED TO BE INITIALIZED.
;;
;;$END
DG53190T ; ALB/SCK - UTILITY TO CREATE RAI/MDS SUBSCRIBER PROTOCOLS ; 10-14-99
+1 ;;5.3;Registration;**190,357,416,1015**;Aug 13, 1993;Build 21
+2 ;
EN ;
+1 NEW DGSTN,FDA,DIR,ERR,HLLP,DGDIV,DGSCN,DGTEST,DGX,DGABRT,HLAPP,HLLINK,DGABRT,I,X,Y,DGIP,DGPORT
+2 ;
+3 WRITE @IOF
+4 FOR I=0:1
SET DGX=$PIECE($TEXT(TEXT+I),";;",2)
IF DGX="$END"
QUIT
WRITE !,DGX
+5 SET DIR(0)="YA"
SET DIR("B")="NO"
SET DIR("A")="Do you wish to continue? "
+6 SET DIR("?")="Enter Yes to continue, or No to quit"
+7 DO ^DIR
KILL DIR
+8 IF 'Y!$DATA(DIRUT)
QUIT
+9 ;
+10 FOR DGX="DIV","SETIP","870","771","408","101","DEM","MFU","FIN"
DO @DGX
IF $GET(DGABRT)
QUIT
+11 QUIT
+12 ;
DIV ;
+1 WRITE !
+2 NEW DIR,DIRUT
+3 SET DIR(0)="PO^40.8:EMZ"
+4 SET DIR("A",1)="Enter the Division you are setting up the"
+5 SET DIR("A")="RAI/MDS HL7 messaging for"
+6 SET DIR("?")="Select the appropriate division to set up the HL7 messaging parameters for."
+7 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(+Y'>0)
SET DGABRT=1
QUIT
+8 SET DGDIV=Y
+9 SET DGSTN=$$SITE^VASITE($$NOW^XLFDT,+DGDIV)
+10 ;
+11 WRITE !!?4,"You have selected : ",$PIECE(DGDIV,"^",2)
+12 WRITE !?4,"Station Number : ",$SELECT(+DGSTN>0:$PIECE(DGSTN,"^",3),1:"Undefined Station Number"),!
+13 ;
+14 IF +DGSTN<0
Begin DoDot:1
+15 WRITE !?4,"You cannot proceed with this division until the station number is"
+16 WRITE !?4,"corrected. Check the STATION NUMBER TIME SENSITIVE"
+17 WRITE !?4,"file to be sure this division is active today."
+18 WRITE !?4,"You may select another division or quit.",!
End DoDot:1
GOTO DIV
+19 ;
+20 NEW DIR,DUOUT,DTOUT
+21 ;
+22 SET DIR(0)="YAO"
SET DIR("A")="Is this correct? "
SET DIR("B")="YES"
+23 SET DIR("?")="Enter Yes or No, Yes will select, No will cancel."
+24 DO ^DIR
KILL DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
QUIT
+25 IF 'Y
GOTO DIV
+26 WRITE !
+27 QUIT
+28 ;
SETIP ; Get IP address and port number
+1 NEW ERR,RSLT,FDA,DIR,DIRUT
+2 ;
IP SET DIR(0)="FAO"
SET DIR("A")="Enter IP address of target COTS receiver: "
+1 SET DIR("?",1)="The IP address must be in the format 'nnn.nnn.nnn.nnn' where"
+2 SET DIR("?",2)="nnn is a numeric, 1-3 numbers in length and should designate"
+3 SET DIR("?")="the static IP address for the COTS database server."
+4 DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
QUIT
+6 ;
+7 IF $PIECE(Y,".",1)'?1.3N
GOTO IP
+8 IF $PIECE(Y,".",2)'?1.3N
GOTO IP
+9 IF $PIECE(Y,".",3)'?1.3N
GOTO IP
+10 IF $PIECE(Y,".",4)'?1.3N
GOTO IP
+11 SET DGIP=$GET(Y)
PORT ;
+1 NEW DIR
+2 SET DIR(0)="FAO"
SET DIR("A")="Enter the port number of the target COTS receiver: "
+3 SET DIR("?",1)="The port number must be a numeric value and should be"
+4 SET DIR("?")="the TCP/IP port the target COTS receiver is listening on."
+5 DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
QUIT
+7 ;
+8 IF Y'?1N.N
GOTO PORT
+9 SET DGPORT=$GET(Y)
+10 QUIT
+11 ;
870 ; Create HL7 Logical Link
+1 NEW ERR,RSLT,FDA,DGLLP,DGLNK
+2 ;
+3 ; Check for existing Logical Link
SET DGLNK="DGRU"_$PIECE(DGSTN,"^",3)
+4 IF $$FIND1^DIC(870,"","MX",DGLNK)>0
Begin DoDot:1
+5 WRITE !?4,"A Logical Link for ",DGLNK," already exists."
End DoDot:1
QUIT
+6 ;
+7 ; Set up the logical link
+8 KILL FDA
+9 SET FDA(1,870,"+1,",.01)=DGLNK
+10 SET FDA(1,870,"+1,",4.5)=1
+11 SET FDA(1,870,"+1,",2)="TCP"
+12 ;p-416
SET FDA(1,870,"+1,",3)="NC"
+13 ;added p-416
SET FDA(1,870,"+1,",200.021)="R"
+14 SET FDA(1,870,"+1,",200.05)=20
+15 SET FDA(1,870,"+1,",200.08)=2.3
+16 SET FDA(1,870,"+1,",400.01)=DGIP
+17 SET FDA(1,870,"+1,",400.02)=DGPORT
+18 SET FDA(1,870,"+1,",400.03)="C"
+19 ;p-416
SET FDA(1,870,"+1,",400.04)="N"
+20 ;
+21 DO UPDATE^DIE("E","FDA(1)","RSLT","ERR(1)")
+22 IF $DATA(ERR)
Begin DoDot:1
+23 WRITE !,DGLNK,": "
DO MSG^DIALOG("WM","","",4,"ERR(1)")
+24 SET DGABRT=1
End DoDot:1
QUIT
+25 SET HLLINK=RSLT(1)
+26 QUIT
+27 ;
771 ; Create HL7 application
+1 NEW ERR,RSLT,FDA,DGNAME
+2 ;
+3 ; Retrieve ien of HL7 messaging mail group
+4 SET DIC=3.8
SET DIC(0)="MZ"
SET X="DGRU ADT/HL7"
+5 DO ^DIC
KILL DIC
+6 SET DGMAIL=$GET(Y(0,0))
+7 ;
+8 KILL FDA
+9 SET DGNAME="DGRU-"_$PIECE(DGSTN,"^",2)
+10 IF $LENGTH(DGNAME)>15
SET DGNAME=$EXTRACT(DGNAME,1,15)
+11 ; Check for existing HL7 Application
+12 ;p-416
SET HLAPP=$$FIND1^DIC(771,"","MX",DGNAME)
IF HLAPP>0
Begin DoDot:1
+13 WRITE !?4,"A HL7 Application for ",DGNAME," already exists."
End DoDot:1
QUIT
+14 ;
+15 SET FDA(1,771,"+1,",.01)=DGNAME
+16 SET FDA(1,771,"+1,",3)=$PIECE(DGSTN,"^",3)
+17 SET FDA(1,771,"+1,",4)=DGMAIL
+18 SET FDA(1,771,"+1,",7)="USA"
+19 ;
+20 DO UPDATE^DIE("E","FDA(1)","RSLT","ERR(1)")
+21 IF $DATA(ERR)
Begin DoDot:1
+22 WRITE !,DGNAME,": "
DO MSG^DIALOG("WM","","",4,"ERR(1)")
+23 SET DGABRT=1
End DoDot:1
QUIT
+24 SET HLAPP=RSLT(1)
+25 QUIT
+26 ;
408 ; Create subscription registry entry
+1 NEW ERR,RSLT,FDA,DGSCN,DGLL,DGAP
+2 ;
+3 SET DGSCN=$$ACT^HLSUB
+4 IF '$DATA(HLAPP)!('$DATA(HLLINK))
Begin DoDot:1
+5 WRITE !?4,"HL7 Application data not available"
End DoDot:1
QUIT
+6 ;
+7 SET DGLL=$$GET1^DIQ(870,HLLINK,.01)
+8 SET DGAP=$$GET1^DIQ(771,HLAPP,.01)
+9 ;
+10 DO UPD^HLSUB(DGSCN,DGLL,2,,,DGAP,.ERR)
+11 IF $DATA(ERR)
Begin DoDot:1
+12 WRITE !,DGSCN,": "
DO MSG^DIALOG("WM","","",4,"ERR(1)")
+13 SET DGABRT=1
End DoDot:1
QUIT
+14 ;
+15 SET FDA(1,40.8,+DGDIV_",",900.01)=DGSCN
+16 ;
+17 KILL ERR
DO FILE^DIE("","FDA(1)","ERR")
+18 IF $DATA(ERR)
Begin DoDot:1
+19 WRITE !
DO MSG^DIALOG("WM","","",4,"ERR(1)")
+20 SET DGABRT=1
End DoDot:1
+21 QUIT
+22 ;
101 ; Create subscriber protocols
+1 NEW EVNT,FDA,ERR,RSLT,DGNAME,IEN,DGCLIENT
+2 ;
+3 SET IEN=0
+4 FOR EVNT="A01","A02","A03","A11","A12","A13","A21","A22","A08"
Begin DoDot:1
+5 SET IEN=IEN+1
+6 ;changed p-357
SET DGNAME="DGRU-RAI-"_EVNT_"-"_HLAPP
+7 ;Check for existing protocol
+8 IF $$FIND1^DIC(101,"","MX",DGNAME)>0
Begin DoDot:2
+9 WRITE !?4,"A protocol for ",DGNAME," already exists."
End DoDot:2
QUIT
+10 ;
+11 SET FDA(1,101,"+"_IEN_",",.01)=DGNAME
+12 SET FDA(1,101,"+"_IEN_",",1)=EVNT_" CLIENT PROTOCOL FOR "_$PIECE(DGSTN,"^",2)
+13 SET FDA(1,101,"+"_IEN_",",4)="subscriber"
+14 SET FDA(1,101,"+"_IEN_",",12)="REGISTRATION"
+15 SET DGCLIENT="DGRU-"_$PIECE(DGSTN,"^",2)
+16 IF $LENGTH(DGCLIENT)>15
SET DGCLIENT=$EXTRACT(DGCLIENT,1,15)
+17 SET FDA(1,101,"+"_IEN_",",770.2)=DGCLIENT
+18 SET FDA(1,101,"+"_IEN_",",770.3)="ADT"
+19 SET FDA(1,101,"+"_IEN_",",770.4)=EVNT
+20 SET FDA(1,101,"+"_IEN_",",770.7)="DGRU"_$PIECE(DGSTN,"^",3)
+21 SET FDA(1,101,"+"_IEN_",",770.11)="ADT"
+22 SET FDA(1,101,"+"_IEN_",",771)="Q"
+23 SET FDA(1,101,"+"_IEN_",",773.1)="YES"
+24 SET FDA(1,101,"+"_IEN_",",773.2)="YES"
+25 KILL ERR,RSLT
+26 DO UPDATE^DIE("E","FDA(1)","RSLT","ERR(1)")
+27 IF +$GET(RSLT(IEN))>0
Begin DoDot:2
+28 SET DIE=101
SET DR="770.95////2.3"
SET DA=RSLT(IEN)
DO ^DIE
KILL DIE
End DoDot:2
+29 IF $DATA(ERR)
Begin DoDot:2
+30 WRITE !
DO MSG^DIALOG("WM","","",4,"ERR(1)")
+31 SET DGABRT=1
End DoDot:2
End DoDot:1
IF $GET(DGABRT)
QUIT
+32 QUIT
+33 ;
DEM ;
+1 NEW FDA,RSLT,ERR,DGNAME,DGCLIENT,DGTXT
+2 ;
+3 ;changed p-357
SET DGNAME="DGRU-PATIENT-A08-"_HLAPP
+4 SET FDA(1,101,"+1,",.01)=DGNAME
+5 ; Check for existing protocol
+6 IF $$FIND1^DIC(101,"","MX",DGNAME)>0
Begin DoDot:1
+7 WRITE !?4,"A protocol for ",DGNAME," already exists."
End DoDot:1
QUIT
+8 ;
+9 SET DGTXT="A08 DEMOGRAPHIC UPDATES CLIENT PROTOCOL FOR "_$PIECE(DGSTN,"^",2)
+10 IF $LENGTH(DGTXT)>62
SET DGTXT=$EXTRACT(DGTXT,1,62)
+11 SET FDA(1,101,"+1,",1)=DGTXT
+12 SET FDA(1,101,"+1,",4)="subscriber"
+13 SET FDA(1,101,"+1,",12)="REGISTRATION"
+14 SET DGCLIENT="DGRU-"_$PIECE(DGSTN,"^",2)
+15 IF $LENGTH(DGCLIENT)>15
SET DGCLIENT=$EXTRACT(DGCLIENT,1,15)
+16 SET FDA(1,101,"+1,",770.2)=DGCLIENT
+17 SET FDA(1,101,"+1,",770.3)="ADT"
+18 SET FDA(1,101,"+1,",770.4)="A08"
+19 SET FDA(1,101,"+1,",770.7)="DGRU"_$PIECE(DGSTN,"^",3)
+20 SET FDA(1,101,"+1,",770.11)="ADT"
+21 SET FDA(1,101,"+1,",771)="Q"
+22 SET FDA(1,101,"+1,",773.1)="YES"
+23 SET FDA(1,101,"+1,",773.2)="YES"
+24 KILL ERR,RSLT
+25 DO UPDATE^DIE("E","FDA(1)","RSLT","ERR(1)")
+26 IF $DATA(ERR)
Begin DoDot:1
+27 WRITE !
DO MSG^DIALOG("WM","","",4,"ERR(1)")
+28 SET DGABRT=1
End DoDot:1
QUIT
+29 ;
+30 IF +$GET(RSLT(1))>0
Begin DoDot:1
+31 SET DIE=101
SET DR="770.95////2.3"
SET DA=RSLT(1)
DO ^DIE
KILL DIE
End DoDot:1
+32 QUIT
+33 ;
MFU ;
+1 NEW FDA,RSLT,ERR,DGNAME,DGCLIENT,DGTXT
+2 SET DGNAME="DGRU-RAI-MFU-"_HLAPP
+3 ; Check for existing protocol
+4 IF $$FIND1^DIC(101,"","MX",DGNAME)>0
Begin DoDot:1
+5 WRITE !?4,"A protocol for ",DGNAME," already exists."
End DoDot:1
QUIT
+6 ;
+7 SET FDA(1,101,"+1,",.01)=DGNAME
+8 SET DGTXT="MFU CLIENT PROTOCOL FOR "_$PIECE(DGSTN,"^",2)
+9 IF $LENGTH(DGTXT)>62
SET DGTXT=$EXTRACT(DGTXT,1,62)
+10 SET FDA(1,101,"+1,",1)=DGTXT
+11 SET FDA(1,101,"+1,",4)="subscriber"
+12 SET FDA(1,101,"+1,",12)="REGISTRATION"
+13 SET DGCLIENT="DGRU-"_$PIECE(DGSTN,"^",2)
+14 IF $LENGTH(DGCLIENT)>15
SET DGCLIENT=$EXTRACT(DGCLIENT,1,15)
+15 SET FDA(1,101,"+1,",770.2)=DGCLIENT
+16 SET FDA(1,101,"+1,",770.3)="MFN"
+17 SET FDA(1,101,"+1,",770.4)="M01"
+18 SET FDA(1,101,"+1,",770.7)="DGRU"_$PIECE(DGSTN,"^",3)
+19 SET FDA(1,101,"+1,",770.11)="MFN"
+20 SET FDA(1,101,"+1,",771)="Q"
+21 SET FDA(1,101,"+1,",773.1)="YES"
+22 SET FDA(1,101,"+1,",773.2)="YES"
+23 KILL ERR,RSLT
+24 DO UPDATE^DIE("E","FDA(1)","RSLT","ERR(1)")
+25 IF $DATA(ERR)
Begin DoDot:1
+26 WRITE !
DO MSG^DIALOG("WM","","",4,"ERR(1)")
+27 SET DGABRT=1
End DoDot:1
QUIT
+28 IF +$GET(RSLT(1))>0
Begin DoDot:1
+29 SET DIE=101
SET DR="770.95////^S X=2.3"
SET DA=RSLT(1)
DO ^DIE
KILL DIE
End DoDot:1
+30 QUIT
+31 ;
FIN ;
+1 WRITE !!?4,"Setup complete"
+2 QUIT
+3 ;
TEXT ;;This routine will setup the necessary HL7 messaging parameters and client
+1 ;;protocols for the selected division for the RAI/MDS Commercial-Off-The-Shelf
+2 ;;system. This is required in order to correctly handle the dynamic addressing
+3 ;;used by VistA to process HL7 messages to the COTS system.
+4 ;;
+5 ;;THIS ROUTINE SHOULD ONLY BE EXECUTED WHEN NEW DIVISIONS USING RAI/MDS NEED TO BE INITIALIZED.
+6 ;;
+7 ;;$END
