DG53190T.m

DG53190T ; ALB/SCK - UTILITY TO CREATE RAI/MDS SUBSCRIBER PROTOCOLS ; 10-14-99

 ;;5.3;Registration;**190,357,416**;Aug 13, 1993

 ;

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DG53190T   8282     printed  Dec 13, 2024@02:36:33                                                                                                                                                                                                    Page 2

DG53190T  ; ALB/SCK - UTILITY TO CREATE RAI/MDS SUBSCRIBER PROTOCOLS ; 10-14-99

 +1       ;;5.3;Registration;**190,357,416**;Aug 13, 1993

 +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