DG53415 ;BPFO/JRP - PRE/POST INITS FOR PATCH 415;7/11/2002 ; 11/5/02 12:45pm
;;5.3;Registration;**415**;Aug 13, 1993
;
Q
;
PRE ;Pre-init entry point
N JUNK1,JUNK2,SUBFILE
;Delete obsolete sub-files
F SUBFILE=2.02,2.06 I $D(^DD(SUBFILE)) D
.;Don't delete if the obsolete sub-file isn't there
.N DEL,X
.S DEL=0
.S X=0 F S X=+$O(^DD(2,"SB",SUBFILE,X)) Q:'X D Q:DEL
..I SUBFILE=2.02 S:(X'=2) DEL=1
..I SUBFILE=2.06 S:(X'=6) DEL=1
.Q:'DEL
.;Remove reference to correct sub-file
.S X=$S(SUBFILE=2.02:2,1:6) K ^DD(2,"SB",SUBFILE,X)
.;Delete sub-file
.S JUNK1(1)=" "
.S JUNK1(2)="The new "_$S(SUBFILE=2.02:"RACE",1:"ETHNICITY")_" INFORMATION multiple is contained in"
.S JUNK1(3)="an obsolete sub-file that still exists on your system."
.S JUNK1(4)="The obsolete sub-file (#"_SUBFILE_") will now be deleted."
.S JUNK1(5)=" "
.D MES^XPDUTL(.JUNK1) K JUNK1
.N DIU
.S DIU=SUBFILE
.S DIU(0)="DST"
.D EN^DIU2
;Delete "bad" B x-reference on RACE file (patch brings in "good" one)
S JUNK1(1)=" "
S JUNK1(2)="The B cross reference on the RACE file (#10) may be listed"
S JUNK1(3)="as the second cross reference of the NAME field (#.01)"
S JUNK1(4)="instead of the first. To ensure that the B cross"
S JUNK1(5)="reference is listed as the first cross reference, the"
S JUNK1(6)="second cross reference of the NAME field will now be"
S JUNK1(7)="deleted."
S JUNK1(8)=" "
D MES^XPDUTL(.JUNK1) K JUNK1
D DELIX^DDMOD(10,.01,2,"W","JUNK1","JUNK2")
Q
;
POST ;Post-init entry point
N JUNK,DIK,RACES,IEN
;Rebuild B x-reference on RACE file
S JUNK(1)=" "
S JUNK(2)="The incorrect B cross reference on the RACE file (#10),"
S JUNK(3)="which was removed by the pre-init, placed the entire value"
S JUNK(4)="of the NAME field (#.01) into the cross reference. The"
S JUNK(5)="correct logic for the B cross reference only places the"
S JUNK(6)="first thirty characters into the cross reference. To"
S JUNK(7)="ensure that the cross referenced values are correct, the"
S JUNK(8)="entire B cross reference will now be deleted and then"
S JUNK(9)="reindexed."
S JUNK(10)=" "
D MES^XPDUTL(.JUNK) K JUNK
K ^DIC(10,"B")
S DIK="^DIC(10,"
S DIK(1)=".01^B"
D ENALL^DIK K DIK
;Inactivate all races
S JUNK(1)=" "
S JUNK(2)="Marking all entries in the RACE file (#10) as inactive"
S JUNK(3)=" "
D MES^XPDUTL(.JUNK) K JUNK
S IEN=0
F S IEN=+$O(^DIC(10,IEN)) Q:'IEN D
.N FDAROOT,MSGROOT,IENS
.S IENS=IEN_","
.S FDAROOT(10,IENS,200)=1
.S FDAROOT(10,IENS,202)=$P($$NOW^XLFDT(),".",1)
.D FILE^DIE("K","FDAROOT","MSGROOT")
.I $D(MSGROOT) D
..S JUNK(1)=" **"
..S JUNK(2)=" ** ERROR"
..S JUNK(3)=" ** Unable to inactivate entry number "_IEN
..S JUNK(4)=" ** Entry should be inactivated via FileMan"
..S JUNK(5)=" **"
..D MES^XPDUTL(.JUNK) K JUNK
;Create/update national entries
S JUNK(1)=" "
S JUNK(2)="Creating/updating nationally supported entries in the RACE"
S JUNK(3)="file (#10)"
S JUNK(4)=" "
D MES^XPDUTL(.JUNK) K JUNK
D BLDLST(.RACES)
S IEN=0
F S IEN=+$O(RACES("FDA",IEN)) Q:'IEN D
.N FDAROOT,IENROOT,MSGROOT,IENS,TMP
.S TMP=RACES("FDA",IEN,.01)
.S IENS=+$O(^DIC(10,"B",$E(TMP,1,30),0)) S:'IENS IENS="+1"
.S IENS=IENS_","
.M FDAROOT(10,IENS)=RACES("FDA",IEN)
.D UPDATE^DIE("","FDAROOT","IENROOT","MSGROOT")
.I $D(MSGROOT) D
..S JUNK(1)=" **"
..S JUNK(2)=" ** ERROR"
..S JUNK(3)=" ** Unable to create entry for "_RACES("FDA",IEN,.01)
..S JUNK(4)=" ** Entry should be created via FileMan"
..S JUNK(5)=" ** Name (.01): "_RACES("FDA",IEN,.01)
..S JUNK(6)=" ** Abbrev (2): "_RACES("FDA",IEN,2)
..S JUNK(7)=" ** HL7 Val (3): "_RACES("FDA",IEN,3)
..S JUNK(8)=" ** CDC Val (4): "_RACES("FDA",IEN,4)
..S JUNK(9)=" ** PTF Val (5): "_RACES("FDA",IEN,5)
..S JUNK(10)=" **"
..D MES^XPDUTL(.JUNK) K JUNK
;Delete RACE identifier
S JUNK(1)=" "
S JUNK(2)="Removing old RACE field (#.06) as an identifier of the"
S JUNK(3)="PATIENT file (#2)."
S JUNK(4)=" "
D MES^XPDUTL(.JUNK) K JUNK
K ^DD(2,0,"ID",.06)
Q
;
BLDLST(ARRAY) ;Build list of valid races
;Input : ARRAY - Array to place values into (pass by value)
;Output : ARRAY("FDA",X,Field) = Value
;Notes : ARRAY will be initiallized (killed) on entry
; : Assumes ARRAY is input
;
N LOOP,TEXT,STOP,X
K ARRAY
S (STOP,LOOP)=0
F S LOOP=LOOP+1 D Q:STOP
.S TEXT=$P($T(RACES+LOOP),";;",2)
.S X=$P(TEXT,"^",1)
.I X="" S STOP=1 Q
.S ARRAY("FDA",LOOP,.01)=X
.F X=2:1:5 S ARRAY("FDA",LOOP,X)=$P(TEXT,"^",X)
.S ARRAY("FDA",LOOP,200)="@"
.S ARRAY("FDA",LOOP,202)="@"
Q
;
RACES ;RACE (#.01)^ABBREVIATION (#2)^HL7 (#3)^CDC (#4)^PTF (#5)
;;AMERICAN INDIAN OR ALASKA NATIVE^3^1002-5^1002-5^3
;;ASIAN^A^2028-9^2028-9^8
;;BLACK OR AFRICAN AMERICAN^B^2054-5^2054-5^9
;;DECLINED TO ANSWER^D^0000-0^^C
;;NATIVE HAWAIIAN OR OTHER PACIFIC ISLANDER^H^2076-8^2076-8^A
;;UNKNOWN BY PATIENT^U^9999-4^^D
;;WHITE^W^2106-3^2106-3^B
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53415 5030 printed Dec 13, 2024@02:37:23 Page 2
DG53415 ;BPFO/JRP - PRE/POST INITS FOR PATCH 415;7/11/2002 ; 11/5/02 12:45pm
+1 ;;5.3;Registration;**415**;Aug 13, 1993
+2 ;
+3 QUIT
+4 ;
PRE ;Pre-init entry point
+1 NEW JUNK1,JUNK2,SUBFILE
+2 ;Delete obsolete sub-files
+3 FOR SUBFILE=2.02,2.06
IF $DATA(^DD(SUBFILE))
Begin DoDot:1
+4 ;Don't delete if the obsolete sub-file isn't there
+5 NEW DEL,X
+6 SET DEL=0
+7 SET X=0
FOR
SET X=+$ORDER(^DD(2,"SB",SUBFILE,X))
if 'X
QUIT
Begin DoDot:2
+8 IF SUBFILE=2.02
if (X'=2)
SET DEL=1
+9 IF SUBFILE=2.06
if (X'=6)
SET DEL=1
End DoDot:2
if DEL
QUIT
+10 if 'DEL
QUIT
+11 ;Remove reference to correct sub-file
+12 SET X=$SELECT(SUBFILE=2.02:2,1:6)
KILL ^DD(2,"SB",SUBFILE,X)
+13 ;Delete sub-file
+14 SET JUNK1(1)=" "
+15 SET JUNK1(2)="The new "_$SELECT(SUBFILE=2.02:"RACE",1:"ETHNICITY")_" INFORMATION multiple is contained in"
+16 SET JUNK1(3)="an obsolete sub-file that still exists on your system."
+17 SET JUNK1(4)="The obsolete sub-file (#"_SUBFILE_") will now be deleted."
+18 SET JUNK1(5)=" "
+19 DO MES^XPDUTL(.JUNK1)
KILL JUNK1
+20 NEW DIU
+21 SET DIU=SUBFILE
+22 SET DIU(0)="DST"
+23 DO EN^DIU2
End DoDot:1
+24 ;Delete "bad" B x-reference on RACE file (patch brings in "good" one)
+25 SET JUNK1(1)=" "
+26 SET JUNK1(2)="The B cross reference on the RACE file (#10) may be listed"
+27 SET JUNK1(3)="as the second cross reference of the NAME field (#.01)"
+28 SET JUNK1(4)="instead of the first. To ensure that the B cross"
+29 SET JUNK1(5)="reference is listed as the first cross reference, the"
+30 SET JUNK1(6)="second cross reference of the NAME field will now be"
+31 SET JUNK1(7)="deleted."
+32 SET JUNK1(8)=" "
+33 DO MES^XPDUTL(.JUNK1)
KILL JUNK1
+34 DO DELIX^DDMOD(10,.01,2,"W","JUNK1","JUNK2")
+35 QUIT
+36 ;
POST ;Post-init entry point
+1 NEW JUNK,DIK,RACES,IEN
+2 ;Rebuild B x-reference on RACE file
+3 SET JUNK(1)=" "
+4 SET JUNK(2)="The incorrect B cross reference on the RACE file (#10),"
+5 SET JUNK(3)="which was removed by the pre-init, placed the entire value"
+6 SET JUNK(4)="of the NAME field (#.01) into the cross reference. The"
+7 SET JUNK(5)="correct logic for the B cross reference only places the"
+8 SET JUNK(6)="first thirty characters into the cross reference. To"
+9 SET JUNK(7)="ensure that the cross referenced values are correct, the"
+10 SET JUNK(8)="entire B cross reference will now be deleted and then"
+11 SET JUNK(9)="reindexed."
+12 SET JUNK(10)=" "
+13 DO MES^XPDUTL(.JUNK)
KILL JUNK
+14 KILL ^DIC(10,"B")
+15 SET DIK="^DIC(10,"
+16 SET DIK(1)=".01^B"
+17 DO ENALL^DIK
KILL DIK
+18 ;Inactivate all races
+19 SET JUNK(1)=" "
+20 SET JUNK(2)="Marking all entries in the RACE file (#10) as inactive"
+21 SET JUNK(3)=" "
+22 DO MES^XPDUTL(.JUNK)
KILL JUNK
+23 SET IEN=0
+24 FOR
SET IEN=+$ORDER(^DIC(10,IEN))
if 'IEN
QUIT
Begin DoDot:1
+25 NEW FDAROOT,MSGROOT,IENS
+26 SET IENS=IEN_","
+27 SET FDAROOT(10,IENS,200)=1
+28 SET FDAROOT(10,IENS,202)=$PIECE($$NOW^XLFDT(),".",1)
+29 DO FILE^DIE("K","FDAROOT","MSGROOT")
+30 IF $DATA(MSGROOT)
Begin DoDot:2
+31 SET JUNK(1)=" **"
+32 SET JUNK(2)=" ** ERROR"
+33 SET JUNK(3)=" ** Unable to inactivate entry number "_IEN
+34 SET JUNK(4)=" ** Entry should be inactivated via FileMan"
+35 SET JUNK(5)=" **"
+36 DO MES^XPDUTL(.JUNK)
KILL JUNK
End DoDot:2
End DoDot:1
+37 ;Create/update national entries
+38 SET JUNK(1)=" "
+39 SET JUNK(2)="Creating/updating nationally supported entries in the RACE"
+40 SET JUNK(3)="file (#10)"
+41 SET JUNK(4)=" "
+42 DO MES^XPDUTL(.JUNK)
KILL JUNK
+43 DO BLDLST(.RACES)
+44 SET IEN=0
+45 FOR
SET IEN=+$ORDER(RACES("FDA",IEN))
if 'IEN
QUIT
Begin DoDot:1
+46 NEW FDAROOT,IENROOT,MSGROOT,IENS,TMP
+47 SET TMP=RACES("FDA",IEN,.01)
+48 SET IENS=+$ORDER(^DIC(10,"B",$EXTRACT(TMP,1,30),0))
if 'IENS
SET IENS="+1"
+49 SET IENS=IENS_","
+50 MERGE FDAROOT(10,IENS)=RACES("FDA",IEN)
+51 DO UPDATE^DIE("","FDAROOT","IENROOT","MSGROOT")
+52 IF $DATA(MSGROOT)
Begin DoDot:2
+53 SET JUNK(1)=" **"
+54 SET JUNK(2)=" ** ERROR"
+55 SET JUNK(3)=" ** Unable to create entry for "_RACES("FDA",IEN,.01)
+56 SET JUNK(4)=" ** Entry should be created via FileMan"
+57 SET JUNK(5)=" ** Name (.01): "_RACES("FDA",IEN,.01)
+58 SET JUNK(6)=" ** Abbrev (2): "_RACES("FDA",IEN,2)
+59 SET JUNK(7)=" ** HL7 Val (3): "_RACES("FDA",IEN,3)
+60 SET JUNK(8)=" ** CDC Val (4): "_RACES("FDA",IEN,4)
+61 SET JUNK(9)=" ** PTF Val (5): "_RACES("FDA",IEN,5)
+62 SET JUNK(10)=" **"
+63 DO MES^XPDUTL(.JUNK)
KILL JUNK
End DoDot:2
End DoDot:1
+64 ;Delete RACE identifier
+65 SET JUNK(1)=" "
+66 SET JUNK(2)="Removing old RACE field (#.06) as an identifier of the"
+67 SET JUNK(3)="PATIENT file (#2)."
+68 SET JUNK(4)=" "
+69 DO MES^XPDUTL(.JUNK)
KILL JUNK
+70 KILL ^DD(2,0,"ID",.06)
+71 QUIT
+72 ;
BLDLST(ARRAY) ;Build list of valid races
+1 ;Input : ARRAY - Array to place values into (pass by value)
+2 ;Output : ARRAY("FDA",X,Field) = Value
+3 ;Notes : ARRAY will be initiallized (killed) on entry
+4 ; : Assumes ARRAY is input
+5 ;
+6 NEW LOOP,TEXT,STOP,X
+7 KILL ARRAY
+8 SET (STOP,LOOP)=0
+9 FOR
SET LOOP=LOOP+1
Begin DoDot:1
+10 SET TEXT=$PIECE($TEXT(RACES+LOOP),";;",2)
+11 SET X=$PIECE(TEXT,"^",1)
+12 IF X=""
SET STOP=1
QUIT
+13 SET ARRAY("FDA",LOOP,.01)=X
+14 FOR X=2:1:5
SET ARRAY("FDA",LOOP,X)=$PIECE(TEXT,"^",X)
+15 SET ARRAY("FDA",LOOP,200)="@"
+16 SET ARRAY("FDA",LOOP,202)="@"
End DoDot:1
if STOP
QUIT
+17 QUIT
+18 ;
RACES ;RACE (#.01)^ABBREVIATION (#2)^HL7 (#3)^CDC (#4)^PTF (#5)
+1 ;;AMERICAN INDIAN OR ALASKA NATIVE^3^1002-5^1002-5^3
+2 ;;ASIAN^A^2028-9^2028-9^8
+3 ;;BLACK OR AFRICAN AMERICAN^B^2054-5^2054-5^9
+4 ;;DECLINED TO ANSWER^D^0000-0^^C
+5 ;;NATIVE HAWAIIAN OR OTHER PACIFIC ISLANDER^H^2076-8^2076-8^A
+6 ;;UNKNOWN BY PATIENT^U^9999-4^^D
+7 ;;WHITE^W^2106-3^2106-3^B
+8 ;;
