DVB4049P.m

DVB4049P ;ALB/ERC - CHANGE IP ADDR FOR HINQ TO VBA CORPORATE ; 9/1/05 1:46pm

 ;;4.0;HINQ;**49**;03/25/92

 ;

 ;this routine will change the IP address for the HINQ inquiries

 ;to the address for the AAC interface engine, which will communicate

 ;with the new VBA corporate database in addition to the C&P and BIRLS

 ;databases.  There will be only one address for all sites.  This is 

 ;being done for the HINQ replacement, interim solution.

 ;this routine will also add three entries into the Anatomical - Loss 

 ;Code file (#395.2) in the POST subroutine

 ;

 D ADDR

 D POST

 Q

 ;

ADDR ;

 N DVBADD,DVBFDA,DVBMSG,DVBNEW,DVBOLDAD,DVBSTA,X,X1,X2

 K ^XTMP("DVBBACK")

 S DVBSTA=$O(^DVB(395,0))

 I '$D(DVBSTA)!($G(DVBSTA)']"") S DVBMSG="HINQ Parameter file (#395) not set properly." G MSG

 I '$D(^DVB(395,DVBSTA,0)) S DVBMSG="HINQ Parameter file (#395) not set properly." G MSG

 ;new AAC server address DVB*4*49

 S X1=DT,X2=30 D C^%DTC

 S ^XTMP("DVBBACK",0)=X_"^"_$$NOW^XLFDT_"^DVB*4*49 - HINQ REPLACEMENT PATCH"

 S DVBOLDAD=$$GET1^DIQ(395,1,22)

 I $G(DVBOLDAD)']"" S DVBOLDAD="Not populated."

 S ^XTMP("DVBBACK","OLDIP")=DVBOLDAD

 S DVBADD="127.0.0.1"

 S DVBFDA(395,"1,",22)=DVBADD

 D FILE^DIE("E","DVBFDA")

 S DVBNEW=$G(^DVB(395,DVBSTA,"HQIP"))

 I $G(DVBNEW)'=DVBADD S DVBMSG="Address change not successful - update manually." G MSG

 S DVBMSG="IP address successfully updated to "_DVBADD_"." D MSG

 S DVBMSG="Previous IP address was "_DVBOLDAD_"." D MSG

 Q

MSG ;add message to the KIDS build

 D BMES^XPDUTL(.DVBMSG)

 Q

 ;

 ;need to add three entries into file 395.2 (Anat-Loss Code file)

 ;this is patterned after DVB448PT

POST ;entry point for post-install, setting up checkpoints

 N %

 S %=$$NEWCP^XPDUTL("DVBLINE","EN^DVB4049P",1)

 Q

 ;

EN ;begin processing

 ;

 N DVBLINE

 ;

 D BMES^XPDUTL("  >> *** Updating ANATOMICAL-LOSS CODE file (#395.2)")

 D MES^XPDUTL("  ")

 ;

 ;get value from checkpoints, previous run

 S DVBLINE=+$$PARCP^XPDUTL("DVBLINE")

 ;

DVBNEW ;add new codes or modify name if code is in use

 ;

 F DVBI=DVBLINE:1 S DVBJ=$P($T(NEWCODE+DVBI),";;",2) Q:DVBJ["$EXIT"  D

 .S DVBCODE=+DVBJ,DVBLINE=DVBI

 .S DVBDESC=$E($P(DVBJ,"^",2),1,30)

 .;

 .;add new code

 .I '$D(^DVB(395.2,"B",DVBCODE)) D  G UPDATECH

 ..K DD,DO

 ..S DIC="^DVB(395.2,",DIC(0)="L",DIC("DR")="1////"_DVBDESC

 ..S X=$P(DVBJ,U),DLAYGO=31

 ..D FILE^DICN

 ..D MES^XPDUTL("adding new code - "_X)

 ..K DLAYGO,DIC,X

 ..Q

 .;

 .;modify name

 .S DVBIEN=+$O(^DVB(395.2,"B",DVBCODE,0))

 .S DVBREC=$G(^DVB(395.2,DVBIEN,0)),DVBOLDSC=$P(DVBREC,U,2) I DVBREC']"" D  G UPDATECH

 ..D MES^XPDUTL("  >>>> error "_DVBCODE_" in B x-reference and not in file 395.2")

 ..Q

 .S DVBOLDC=$P(DVBREC,"^") I DVBOLDC=DVBCODE,(DVBOLDSC=DVBDESC) G UPDATECH

 .I DVBOLDC'=DVBCODE D

 ..S DA=DVBIEN,DIE="^DVB(395.2,",DR=".01////"_DVBCODE_";1////"_DVBDESC

 ..D ^DIE

 ..K DR,DA,DIE

 .I DVBOLDSC'=DVBDESC D

 ..S DA=DVBIEN,DIE="^DVB(395.2,",DR="1////"_DVBDESC

 ..D ^DIE

 ..K DA,DIE,DR

 ..D MES^XPDUTL(DVBCODE_": changing description...")

 ..D MES^XPDUTL("          from:  "_DVBOLDSC)

 ..D MES^XPDUTL("            to:  "_DVBDESC)

 .;

UPDATECH .;update checkpoint

 .S %=$$UPCP^XPDUTL("DVBLINE",DVBLINE)

 .Q

 K DVBCODE,DVBI,DVBIEN,DVBJ,DVBNAME,DVBOLDC,DVBOLDN,DVBREC,DVBDESC,DVBOLDSC

 Q

 ;

NEWCODE ;codes to be added or changed

 ;;16^Deafness, Total

 ;;17^Aphonia

 ;;29^Deafnessand Aphonia

 ;;$EXIT

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DVB4049P   3439     printed  Mar 13, 2025@21:02:08                                                                                                                                                                                                    Page 2

DVB4049P  ;ALB/ERC - CHANGE IP ADDR FOR HINQ TO VBA CORPORATE ; 9/1/05 1:46pm

 +1       ;;4.0;HINQ;**49**;03/25/92

 +2       ;

 +3       ;this routine will change the IP address for the HINQ inquiries

 +4       ;to the address for the AAC interface engine, which will communicate

 +5       ;with the new VBA corporate database in addition to the C&P and BIRLS

 +6       ;databases.  There will be only one address for all sites.  This is 

 +7       ;being done for the HINQ replacement, interim solution.

 +8       ;this routine will also add three entries into the Anatomical - Loss 

 +9       ;Code file (#395.2) in the POST subroutine

 +10      ;

 +11       DO ADDR

 +12       DO POST

 +13       QUIT 

 +14      ;

ADDR      ;

 +1        NEW DVBADD,DVBFDA,DVBMSG,DVBNEW,DVBOLDAD,DVBSTA,X,X1,X2

 +2        KILL ^XTMP("DVBBACK")

 +3        SET DVBSTA=$ORDER(^DVB(395,0))

 +4        IF '$DATA(DVBSTA)!($GET(DVBSTA)']"")

               SET DVBMSG="HINQ Parameter file (#395) not set properly."

               GOTO MSG

 +5        IF '$DATA(^DVB(395,DVBSTA,0))

               SET DVBMSG="HINQ Parameter file (#395) not set properly."

               GOTO MSG

 +6       ;new AAC server address DVB*4*49

 +7        SET X1=DT

           SET X2=30

           DO C^%DTC

 +8        SET ^XTMP("DVBBACK",0)=X_"^"_$$NOW^XLFDT_"^DVB*4*49 - HINQ REPLACEMENT PATCH"

 +9        SET DVBOLDAD=$$GET1^DIQ(395,1,22)

 +10       IF $GET(DVBOLDAD)']""

               SET DVBOLDAD="Not populated."

 +11       SET ^XTMP("DVBBACK","OLDIP")=DVBOLDAD

 +12       SET DVBADD="127.0.0.1"

 +13       SET DVBFDA(395,"1,",22)=DVBADD

 +14       DO FILE^DIE("E","DVBFDA")

 +15       SET DVBNEW=$GET(^DVB(395,DVBSTA,"HQIP"))

 +16       IF $GET(DVBNEW)'=DVBADD

               SET DVBMSG="Address change not successful - update manually."

               GOTO MSG

 +17       SET DVBMSG="IP address successfully updated to "_DVBADD_"."

           DO MSG

 +18       SET DVBMSG="Previous IP address was "_DVBOLDAD_"."

           DO MSG

 +19       QUIT 

MSG       ;add message to the KIDS build

 +1        DO BMES^XPDUTL(.DVBMSG)

 +2        QUIT 

 +3       ;

 +4       ;need to add three entries into file 395.2 (Anat-Loss Code file)

 +5       ;this is patterned after DVB448PT

POST      ;entry point for post-install, setting up checkpoints

 +1        NEW %

 +2        SET %=$$NEWCP^XPDUTL("DVBLINE","EN^DVB4049P",1)

 +3        QUIT 

 +4       ;

EN        ;begin processing

 +1       ;

 +2        NEW DVBLINE

 +3       ;

 +4        DO BMES^XPDUTL("  >> *** Updating ANATOMICAL-LOSS CODE file (#395.2)")

 +5        DO MES^XPDUTL("  ")

 +6       ;

 +7       ;get value from checkpoints, previous run

 +8        SET DVBLINE=+$$PARCP^XPDUTL("DVBLINE")

 +9       ;

DVBNEW    ;add new codes or modify name if code is in use

 +1       ;

 +2        FOR DVBI=DVBLINE:1

               SET DVBJ=$PIECE($TEXT(NEWCODE+DVBI),";;",2)

               if DVBJ["$EXIT"

                   QUIT 

               Begin DoDot:1

 +3                SET DVBCODE=+DVBJ

                   SET DVBLINE=DVBI

 +4                SET DVBDESC=$EXTRACT($PIECE(DVBJ,"^",2),1,30)

 +5       ;

 +6       ;add new code

 +7                IF '$DATA(^DVB(395.2,"B",DVBCODE))

                       Begin DoDot:2

 +8                        KILL DD,DO

 +9                        SET DIC="^DVB(395.2,"

                           SET DIC(0)="L"

                           SET DIC("DR")="1////"_DVBDESC

 +10                       SET X=$PIECE(DVBJ,U)

                           SET DLAYGO=31

 +11                       DO FILE^DICN

 +12                       DO MES^XPDUTL("adding new code - "_X)

 +13                       KILL DLAYGO,DIC,X

 +14                       QUIT 

                       End DoDot:2

                       GOTO UPDATECH

 +15      ;

 +16      ;modify name

 +17               SET DVBIEN=+$ORDER(^DVB(395.2,"B",DVBCODE,0))

 +18               SET DVBREC=$GET(^DVB(395.2,DVBIEN,0))

                   SET DVBOLDSC=$PIECE(DVBREC,U,2)

                   IF DVBREC']""

                       Begin DoDot:2

 +19                       DO MES^XPDUTL("  >>>> error "_DVBCODE_" in B x-reference and not in file 395.2")

 +20                       QUIT 

                       End DoDot:2

                       GOTO UPDATECH

 +21               SET DVBOLDC=$PIECE(DVBREC,"^")

                   IF DVBOLDC=DVBCODE

                       IF (DVBOLDSC=DVBDESC)

                           GOTO UPDATECH

 +22               IF DVBOLDC'=DVBCODE

                       Begin DoDot:2

 +23                       SET DA=DVBIEN

                           SET DIE="^DVB(395.2,"

                           SET DR=".01////"_DVBCODE_";1////"_DVBDESC

 +24                       DO ^DIE

 +25                       KILL DR,DA,DIE

                       End DoDot:2

 +26               IF DVBOLDSC'=DVBDESC

                       Begin DoDot:2

 +27                       SET DA=DVBIEN

                           SET DIE="^DVB(395.2,"

                           SET DR="1////"_DVBDESC

 +28                       DO ^DIE

 +29                       KILL DA,DIE,DR

 +30                       DO MES^XPDUTL(DVBCODE_": changing description...")

 +31                       DO MES^XPDUTL("          from:  "_DVBOLDSC)

 +32                       DO MES^XPDUTL("            to:  "_DVBDESC)

                       End DoDot:2

 +33      ;

UPDATECH  ;update checkpoint

 +1                SET %=$$UPCP^XPDUTL("DVBLINE",DVBLINE)

 +2                QUIT 

               End DoDot:1

 +3        KILL DVBCODE,DVBI,DVBIEN,DVBJ,DVBNAME,DVBOLDC,DVBOLDN,DVBREC,DVBDESC,DVBOLDSC

 +4        QUIT 

 +5       ;

NEWCODE   ;codes to be added or changed

 +1       ;;16^Deafness, Total

 +2       ;;17^Aphonia

 +3       ;;29^Deafnessand Aphonia

 +4       ;;$EXIT

 +5        QUIT