AFJXPRE ;FO-OAKLAND/GMB-Pre/Post-init ;10/19/2001 07:29
;;5.1;Network Health Exchange;**30,31**;Jan 23, 1996
ENTER ;
D BMES^XPDUTL("Change Domain fields to point to file 4.2.")
I $D(^DD(537000,0,"ID","W8")) D Q
. D BMES^XPDUTL("Already done - we don't need to do it again.")
N AXCHANGE,AXLAST10
S AXLAST10=$O(^AFJ(537010,99999999999999),-1)
D FILE000
D FILE025
D:$G(AXCHANGE) FILE010
D DD000
Q
FILE000 ;
D BMES^XPDUTL("File 537000: Change field 8 from free text to point to file 4.2")
N AXCNT,AXREF,AXIEN,AXDOM,AXDOMSAV,AXDOMIEN,XPDIDTOT
S XPDIDTOT=0
D UPDATE^XPDID(0)
S XPDIDTOT=$P(^AFJ(537000,0),U,4)
D BMES^XPDUTL("Change "_XPDIDTOT_" records...")
S (AXREF,AXDOMSAV)="",(AXIEN,AXCNT)=0
F S AXREF=$O(^AFJ(537000,"C",AXREF)) Q:AXREF="" D
. F S AXIEN=$O(^AFJ(537000,"C",AXREF,AXIEN)) Q:'AXIEN D
. . S AXCNT=AXCNT+1
. . I AXCNT#1000=0 D UPDATE^XPDID(AXCNT)
. . Q:+AXREF=AXREF
. . S AXDOM=$P($G(^AFJ(537000,AXIEN,1)),U)
. . I AXDOM="" K ^AFJ(537000,"C",AXREF,AXIEN)
. . I AXDOM'=AXDOMSAV D
. . . S AXDOMSAV=AXDOM
. . . S AXDOMIEN=$$FIND1^DIC(4.2,"","MX",AXDOM,"B^C")
. . ; *** What if AXDOMIEN=0? ***
. . S DIE="^AFJ(537000,",DA=AXIEN,DR="8////"_AXDOMIEN
. . D ^DIE
D UPDATE^XPDID(XPDIDTOT)
D BMES^XPDUTL(AXCNT_" records in file 537000.")
I AXCNT'=$P(^AFJ(537000,0),U,4) D
. D MES^XPDUTL("Changing the count in the zero node in file 537000 from "_$P(^AFJ(537000,0),U,4)_" to "_AXCNT_".")
. S $P(^AFJ(537000,0),U,4)=AXCNT
D BMES^XPDUTL("File 537000: Let's check our work...")
S AXREF=":"
F S AXREF=$O(^AFJ(537000,"C",AXREF)) Q:AXREF="" K ^(AXREF)
S XPDIDTOT=0
D UPDATE^XPDID(0)
S XPDIDTOT=$P(^AFJ(537000,0),U,4)
S (AXIEN,AXCNT)=0
F S AXIEN=$O(^AFJ(537000,AXIEN)) Q:'AXIEN D
. S AXCNT=AXCNT+1
. I AXCNT#1000=0 D UPDATE^XPDID(AXCNT)
. S AXDOM=$P($G(^AFJ(537000,AXIEN,1)),U)
. Q:+AXDOM=AXDOM
. Q:AXDOM=""
. S AXDOMIEN=$$FIND1^DIC(4.2,"","MX",AXDOM,"B^C")
. ; *** What if AXDOMIEN=0? ***
. S DIE="^AFJ(537000,",DA=AXIEN,DR="8////"_AXDOMIEN
. D ^DIE
D UPDATE^XPDID(XPDIDTOT)
D BMES^XPDUTL(AXCNT_" records in file 537000.")
I AXCNT=$P(^AFJ(537000,0),U,4) Q
D MES^XPDUTL("Changing the count in the zero node in file 537000 from "_$P(^AFJ(537000,0),U,4)_" to "_AXCNT_".")
S $P(^AFJ(537000,0),U,4)=AXCNT
Q
FILE025 ;
D BMES^XPDUTL("File 537025: Change field .01 from free text to point to file 4.2")
N AXCNT,AXIEN,AXDOM,AXDOMIEN,XPDIDTOT
S XPDIDTOT=0
D UPDATE^XPDID(0)
S XPDIDTOT=$P(^AFJ(537025,0),U,4)
D BMES^XPDUTL("Change "_XPDIDTOT_" records...")
S (AXIEN,AXCNT)=0
F S AXIEN=$O(^AFJ(537025,AXIEN)) Q:'AXIEN D
. S AXCNT=AXCNT+1
. D UPDATE^XPDID(AXCNT)
. S AXDOM=$P(^AFJ(537025,AXIEN,0),U)
. Q:+AXDOM=AXDOM
. S AXCHANGE=1
. S AXDOMIEN=$$FIND1^DIC(4.2,"","MX",AXDOM,"B^C")
. I AXDOMIEN D Q
. . S AXCHANGE(AXIEN)=AXDOMIEN
. . S DIE="^AFJ(537025,",DA=AXIEN,DR=".01////"_AXDOMIEN
. . D ^DIE
. S AXCNT=AXCNT-1
. S DIK="^AFJ(537025,",DA=AXIEN D ^DIK
D UPDATE^XPDID(XPDIDTOT)
D BMES^XPDUTL(AXCNT_" records in file 537025.")
I AXCNT=$P(^AFJ(537025,0),U,4) Q
D MES^XPDUTL("Changing the count in the zero node in file 537025 from "_$P(^AFJ(537025,0),U,4)_" to "_AXCNT_".")
S $P(^AFJ(537025,0),U,4)=AXCNT
Q
FILE010 ;
D BMES^XPDUTL("File 537010: Change field .01 in the 'Records Available At' multiple")
D MES^XPDUTL("from pointing to file 537025 to point to file 4.2")
N AXCNT,AXPT,AXPTR,AXDOMIEN,XPDIDTOT
S XPDIDTOT=0
D UPDATE^XPDID(0)
S XPDIDTOT=$P(^AFJ(537010,0),U,4)
D BMES^XPDUTL("Change "_XPDIDTOT_" records...")
S (AXPT,AXCNT)=0
F S AXPT=$O(^AFJ(537010,AXPT)) Q:'AXPT D
. S AXCNT=AXCNT+1
. I AXCNT#1000=0 D UPDATE^XPDID(AXCNT)
. Q:AXPT>AXLAST10
. S AXIEN=0
. F S AXIEN=$O(^AFJ(537010,AXPT,1,AXIEN)) Q:'AXIEN D
. . S AXPTR=+$P($G(^AFJ(537010,AXPT,1,AXIEN,0)),U)
. . I $D(AXCHANGE(AXPTR)) D Q
. . . N AXFDA
. . . S AXFDA(537010.04,AXIEN_","_AXPT_",",.01)=AXCHANGE(AXPTR)
. . . D FILE^DIE("","AXFDA")
. . S DA(1)=AXPT,DA=AXIEN
. . S DIK="^AFJ(537010,"_AXPT_",1,"
. . D ^DIK
D UPDATE^XPDID(XPDIDTOT)
D BMES^XPDUTL(AXCNT_" records in file 537010.")
I AXCNT=$P(^AFJ(537010,0),U,4) Q
D MES^XPDUTL("Changing the count in the zero node in file 537010 from "_$P(^AFJ(537010,0),U,4)_" to "_AXCNT_".")
S $P(^AFJ(537010,0),U,4)=AXCNT
Q
DD000 ;
D BMES^XPDUTL("Change identifiers in file 537000 to write identifiers.")
K ^DD(537000,0,"ID",1)
K ^DD(537000,0,"ID",3)
K ^DD(537000,0,"ID",7)
K ^DD(537000,0,"ID",8)
S ^DD(537000,0,"ID","W1")="N AX S AX=$P(^(0),U,2) D EN^DDIOL($E(AX,4,5)_""-""_$E(AX,6,7)_""-""_$E(AX,2,3),"""",""?0"")"
S ^DD(537000,0,"ID","W3")="D EN^DDIOL($P(^(0),U,4),"""",""?0"")"
S ^DD(537000,0,"ID","W7")="D EN^DDIOL($P(^(0),U,8),"""",""?0"")"
S ^DD(537000,0,"ID","W8")="D EN^DDIOL($$GET1^DIQ(537000,Y_"","",8),"""",""?0"")"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HAFJXPRE 4884 printed Sep 23, 2025@19:54:15 Page 2
AFJXPRE ;FO-OAKLAND/GMB-Pre/Post-init ;10/19/2001 07:29
+1 ;;5.1;Network Health Exchange;**30,31**;Jan 23, 1996
ENTER ;
+1 DO BMES^XPDUTL("Change Domain fields to point to file 4.2.")
+2 IF $DATA(^DD(537000,0,"ID","W8"))
Begin DoDot:1
+3 DO BMES^XPDUTL("Already done - we don't need to do it again.")
End DoDot:1
QUIT
+4 NEW AXCHANGE,AXLAST10
+5 SET AXLAST10=$ORDER(^AFJ(537010,99999999999999),-1)
+6 DO FILE000
+7 DO FILE025
+8 if $GET(AXCHANGE)
DO FILE010
+9 DO DD000
+10 QUIT
FILE000 ;
+1 DO BMES^XPDUTL("File 537000: Change field 8 from free text to point to file 4.2")
+2 NEW AXCNT,AXREF,AXIEN,AXDOM,AXDOMSAV,AXDOMIEN,XPDIDTOT
+3 SET XPDIDTOT=0
+4 DO UPDATE^XPDID(0)
+5 SET XPDIDTOT=$PIECE(^AFJ(537000,0),U,4)
+6 DO BMES^XPDUTL("Change "_XPDIDTOT_" records...")
+7 SET (AXREF,AXDOMSAV)=""
SET (AXIEN,AXCNT)=0
+8 FOR
SET AXREF=$ORDER(^AFJ(537000,"C",AXREF))
if AXREF=""
QUIT
Begin DoDot:1
+9 FOR
SET AXIEN=$ORDER(^AFJ(537000,"C",AXREF,AXIEN))
if 'AXIEN
QUIT
Begin DoDot:2
+10 SET AXCNT=AXCNT+1
+11 IF AXCNT#1000=0
DO UPDATE^XPDID(AXCNT)
+12 if +AXREF=AXREF
QUIT
+13 SET AXDOM=$PIECE($GET(^AFJ(537000,AXIEN,1)),U)
+14 IF AXDOM=""
KILL ^AFJ(537000,"C",AXREF,AXIEN)
+15 IF AXDOM'=AXDOMSAV
Begin DoDot:3
+16 SET AXDOMSAV=AXDOM
+17 SET AXDOMIEN=$$FIND1^DIC(4.2,"","MX",AXDOM,"B^C")
End DoDot:3
+18 ; *** What if AXDOMIEN=0? ***
+19 SET DIE="^AFJ(537000,"
SET DA=AXIEN
SET DR="8////"_AXDOMIEN
+20 DO ^DIE
End DoDot:2
End DoDot:1
+21 DO UPDATE^XPDID(XPDIDTOT)
+22 DO BMES^XPDUTL(AXCNT_" records in file 537000.")
+23 IF AXCNT'=$PIECE(^AFJ(537000,0),U,4)
Begin DoDot:1
+24 DO MES^XPDUTL("Changing the count in the zero node in file 537000 from "_$PIECE(^AFJ(537000,0),U,4)_" to "_AXCNT_".")
+25 SET $PIECE(^AFJ(537000,0),U,4)=AXCNT
End DoDot:1
+26 DO BMES^XPDUTL("File 537000: Let's check our work...")
+27 SET AXREF=":"
+28 FOR
SET AXREF=$ORDER(^AFJ(537000,"C",AXREF))
if AXREF=""
QUIT
KILL ^(AXREF)
+29 SET XPDIDTOT=0
+30 DO UPDATE^XPDID(0)
+31 SET XPDIDTOT=$PIECE(^AFJ(537000,0),U,4)
+32 SET (AXIEN,AXCNT)=0
+33 FOR
SET AXIEN=$ORDER(^AFJ(537000,AXIEN))
if 'AXIEN
QUIT
Begin DoDot:1
+34 SET AXCNT=AXCNT+1
+35 IF AXCNT#1000=0
DO UPDATE^XPDID(AXCNT)
+36 SET AXDOM=$PIECE($GET(^AFJ(537000,AXIEN,1)),U)
+37 if +AXDOM=AXDOM
QUIT
+38 if AXDOM=""
QUIT
+39 SET AXDOMIEN=$$FIND1^DIC(4.2,"","MX",AXDOM,"B^C")
+40 ; *** What if AXDOMIEN=0? ***
+41 SET DIE="^AFJ(537000,"
SET DA=AXIEN
SET DR="8////"_AXDOMIEN
+42 DO ^DIE
End DoDot:1
+43 DO UPDATE^XPDID(XPDIDTOT)
+44 DO BMES^XPDUTL(AXCNT_" records in file 537000.")
+45 IF AXCNT=$PIECE(^AFJ(537000,0),U,4)
QUIT
+46 DO MES^XPDUTL("Changing the count in the zero node in file 537000 from "_$PIECE(^AFJ(537000,0),U,4)_" to "_AXCNT_".")
+47 SET $PIECE(^AFJ(537000,0),U,4)=AXCNT
+48 QUIT
FILE025 ;
+1 DO BMES^XPDUTL("File 537025: Change field .01 from free text to point to file 4.2")
+2 NEW AXCNT,AXIEN,AXDOM,AXDOMIEN,XPDIDTOT
+3 SET XPDIDTOT=0
+4 DO UPDATE^XPDID(0)
+5 SET XPDIDTOT=$PIECE(^AFJ(537025,0),U,4)
+6 DO BMES^XPDUTL("Change "_XPDIDTOT_" records...")
+7 SET (AXIEN,AXCNT)=0
+8 FOR
SET AXIEN=$ORDER(^AFJ(537025,AXIEN))
if 'AXIEN
QUIT
Begin DoDot:1
+9 SET AXCNT=AXCNT+1
+10 DO UPDATE^XPDID(AXCNT)
+11 SET AXDOM=$PIECE(^AFJ(537025,AXIEN,0),U)
+12 if +AXDOM=AXDOM
QUIT
+13 SET AXCHANGE=1
+14 SET AXDOMIEN=$$FIND1^DIC(4.2,"","MX",AXDOM,"B^C")
+15 IF AXDOMIEN
Begin DoDot:2
+16 SET AXCHANGE(AXIEN)=AXDOMIEN
+17 SET DIE="^AFJ(537025,"
SET DA=AXIEN
SET DR=".01////"_AXDOMIEN
+18 DO ^DIE
End DoDot:2
QUIT
+19 SET AXCNT=AXCNT-1
+20 SET DIK="^AFJ(537025,"
SET DA=AXIEN
DO ^DIK
End DoDot:1
+21 DO UPDATE^XPDID(XPDIDTOT)
+22 DO BMES^XPDUTL(AXCNT_" records in file 537025.")
+23 IF AXCNT=$PIECE(^AFJ(537025,0),U,4)
QUIT
+24 DO MES^XPDUTL("Changing the count in the zero node in file 537025 from "_$PIECE(^AFJ(537025,0),U,4)_" to "_AXCNT_".")
+25 SET $PIECE(^AFJ(537025,0),U,4)=AXCNT
+26 QUIT
FILE010 ;
+1 DO BMES^XPDUTL("File 537010: Change field .01 in the 'Records Available At' multiple")
+2 DO MES^XPDUTL("from pointing to file 537025 to point to file 4.2")
+3 NEW AXCNT,AXPT,AXPTR,AXDOMIEN,XPDIDTOT
+4 SET XPDIDTOT=0
+5 DO UPDATE^XPDID(0)
+6 SET XPDIDTOT=$PIECE(^AFJ(537010,0),U,4)
+7 DO BMES^XPDUTL("Change "_XPDIDTOT_" records...")
+8 SET (AXPT,AXCNT)=0
+9 FOR
SET AXPT=$ORDER(^AFJ(537010,AXPT))
if 'AXPT
QUIT
Begin DoDot:1
+10 SET AXCNT=AXCNT+1
+11 IF AXCNT#1000=0
DO UPDATE^XPDID(AXCNT)
+12 if AXPT>AXLAST10
QUIT
+13 SET AXIEN=0
+14 FOR
SET AXIEN=$ORDER(^AFJ(537010,AXPT,1,AXIEN))
if 'AXIEN
QUIT
Begin DoDot:2
+15 SET AXPTR=+$PIECE($GET(^AFJ(537010,AXPT,1,AXIEN,0)),U)
+16 IF $DATA(AXCHANGE(AXPTR))
Begin DoDot:3
+17 NEW AXFDA
+18 SET AXFDA(537010.04,AXIEN_","_AXPT_",",.01)=AXCHANGE(AXPTR)
+19 DO FILE^DIE("","AXFDA")
End DoDot:3
QUIT
+20 SET DA(1)=AXPT
SET DA=AXIEN
+21 SET DIK="^AFJ(537010,"_AXPT_",1,"
+22 DO ^DIK
End DoDot:2
End DoDot:1
+23 DO UPDATE^XPDID(XPDIDTOT)
+24 DO BMES^XPDUTL(AXCNT_" records in file 537010.")
+25 IF AXCNT=$PIECE(^AFJ(537010,0),U,4)
QUIT
+26 DO MES^XPDUTL("Changing the count in the zero node in file 537010 from "_$PIECE(^AFJ(537010,0),U,4)_" to "_AXCNT_".")
+27 SET $PIECE(^AFJ(537010,0),U,4)=AXCNT
+28 QUIT
DD000 ;
+1 DO BMES^XPDUTL("Change identifiers in file 537000 to write identifiers.")
+2 KILL ^DD(537000,0,"ID",1)
+3 KILL ^DD(537000,0,"ID",3)
+4 KILL ^DD(537000,0,"ID",7)
+5 KILL ^DD(537000,0,"ID",8)
+6 SET ^DD(537000,0,"ID","W1")="N AX S AX=$P(^(0),U,2) D EN^DDIOL($E(AX,4,5)_""-""_$E(AX,6,7)_""-""_$E(AX,2,3),"""",""?0"")"
+7 SET ^DD(537000,0,"ID","W3")="D EN^DDIOL($P(^(0),U,4),"""",""?0"")"
+8 SET ^DD(537000,0,"ID","W7")="D EN^DDIOL($P(^(0),U,8),"""",""?0"")"
+9 SET ^DD(537000,0,"ID","W8")="D EN^DDIOL($$GET1^DIQ(537000,Y_"","",8),"""",""?0"")"
+10 QUIT
