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 ---[H[J[2J[HDVB4049P 3439 printed Dec 13, 2024@01:57:30 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
