Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DG53415

DG53415.m

Go to the documentation of this file. 
  1. DG53415 ;BPFO/JRP - PRE/POST INITS FOR PATCH 415;7/11/2002 ; 11/5/02 12:45pm
  1.  ;;5.3;Registration;**415,1015**;Aug 13, 1993;Build 21
  1.  ;
  1.  Q
  1.  ;
  1. PRE ;Pre-init entry point
  1.  N JUNK1,JUNK2,SUBFILE
  1.  ;Delete obsolete sub-files
  1.  F SUBFILE=2.02,2.06 I $D(^DD(SUBFILE)) D
  1.  .;Don't delete if the obsolete sub-file isn't there
  1.  .N DEL,X
  1.  .S DEL=0
  1.  .S X=0 F  S X=+$O(^DD(2,"SB",SUBFILE,X)) Q:'X  D  Q:DEL
  1.  ..I SUBFILE=2.02 S:(X'=2) DEL=1
  1.  ..I SUBFILE=2.06 S:(X'=6) DEL=1
  1.  .Q:'DEL
  1.  .;Remove reference to correct sub-file
  1.  .S X=$S(SUBFILE=2.02:2,1:6) K ^DD(2,"SB",SUBFILE,X)
  1.  .;Delete sub-file
  1.  .S JUNK1(1)=" "
  1.  .S JUNK1(2)="The new "_$S(SUBFILE=2.02:"RACE",1:"ETHNICITY")_" INFORMATION multiple is contained in"
  1.  .S JUNK1(3)="an obsolete sub-file that still exists on your system."
  1.  .S JUNK1(4)="The obsolete sub-file (#"_SUBFILE_") will now be deleted."
  1.  .S JUNK1(5)=" "
  1.  .D MES^XPDUTL(.JUNK1) K JUNK1
  1.  .N DIU
  1.  .S DIU=SUBFILE
  1.  .S DIU(0)="DST"
  1.  .D EN^DIU2
  1.  ;Delete "bad" B x-reference on RACE file (patch brings in "good" one)
  1.  S JUNK1(1)=" "
  1.  S JUNK1(2)="The B cross reference on the RACE file (#10) may be listed"
  1.  S JUNK1(3)="as the second cross reference of the NAME field (#.01)"
  1.  S JUNK1(4)="instead of the first.  To ensure that the B cross"
  1.  S JUNK1(5)="reference is listed as the first cross reference, the"
  1.  S JUNK1(6)="second cross reference of the NAME field will now be"
  1.  S JUNK1(7)="deleted."
  1.  S JUNK1(8)=" "
  1.  D MES^XPDUTL(.JUNK1) K JUNK1
  1.  D DELIX^DDMOD(10,.01,2,"W","JUNK1","JUNK2")
  1.  Q
  1.  ;
  1. POST ;Post-init entry point
  1.  N JUNK,DIK,RACES,IEN
  1.  ;Rebuild B x-reference on RACE file
  1.  S JUNK(1)=" "
  1.  S JUNK(2)="The incorrect B cross reference on the RACE file (#10),"
  1.  S JUNK(3)="which was removed by the pre-init, placed the entire value"
  1.  S JUNK(4)="of the NAME field (#.01) into the cross reference.  The"
  1.  S JUNK(5)="correct logic for the B cross reference only places the"
  1.  S JUNK(6)="first thirty characters into the cross reference.  To"
  1.  S JUNK(7)="ensure that the cross referenced values are correct, the"
  1.  S JUNK(8)="entire B cross reference will now be deleted and then"
  1.  S JUNK(9)="reindexed."
  1.  S JUNK(10)=" "
  1.  D MES^XPDUTL(.JUNK) K JUNK
  1.  K ^DIC(10,"B")
  1.  S DIK="^DIC(10,"
  1.  S DIK(1)=".01^B"
  1.  D ENALL^DIK K DIK
  1.  ;Inactivate all races
  1.  S JUNK(1)=" "
  1.  S JUNK(2)="Marking all entries in the RACE file (#10) as inactive"
  1.  S JUNK(3)=" "
  1.  D MES^XPDUTL(.JUNK) K JUNK
  1.  S IEN=0
  1.  F  S IEN=+$O(^DIC(10,IEN)) Q:'IEN  D
  1.  .N FDAROOT,MSGROOT,IENS
  1.  .S IENS=IEN_","
  1.  .S FDAROOT(10,IENS,200)=1
  1.  .S FDAROOT(10,IENS,202)=$P($$NOW^XLFDT(),".",1)
  1.  .D FILE^DIE("K","FDAROOT","MSGROOT")
  1.  .I $D(MSGROOT) D
  1.  ..S JUNK(1)="  **"
  1.  ..S JUNK(2)="  ** ERROR"
  1.  ..S JUNK(3)="  ** Unable to inactivate entry number "_IEN
  1.  ..S JUNK(4)="  ** Entry should be inactivated via FileMan"
  1.  ..S JUNK(5)="  **"
  1.  ..D MES^XPDUTL(.JUNK) K JUNK
  1.  ;Create/update national entries
  1.  S JUNK(1)=" "
  1.  S JUNK(2)="Creating/updating nationally supported entries in the RACE"
  1.  S JUNK(3)="file (#10)"
  1.  S JUNK(4)=" "
  1.  D MES^XPDUTL(.JUNK) K JUNK
  1.  D BLDLST(.RACES)
  1.  S IEN=0
  1.  F  S IEN=+$O(RACES("FDA",IEN)) Q:'IEN  D
  1.  .N FDAROOT,IENROOT,MSGROOT,IENS,TMP
  1.  .S TMP=RACES("FDA",IEN,.01)
  1.  .S IENS=+$O(^DIC(10,"B",$E(TMP,1,30),0)) S:'IENS IENS="+1"
  1.  .S IENS=IENS_","
  1.  .M FDAROOT(10,IENS)=RACES("FDA",IEN)
  1.  .D UPDATE^DIE("","FDAROOT","IENROOT","MSGROOT")
  1.  .I $D(MSGROOT) D
  1.  ..S JUNK(1)="  **"
  1.  ..S JUNK(2)="  ** ERROR"
  1.  ..S JUNK(3)="  ** Unable to create entry for "_RACES("FDA",IEN,.01)
  1.  ..S JUNK(4)="  ** Entry should be created via FileMan"
  1.  ..S JUNK(5)="  **    Name  (.01): "_RACES("FDA",IEN,.01)
  1.  ..S JUNK(6)="  **    Abbrev  (2): "_RACES("FDA",IEN,2)
  1.  ..S JUNK(7)="  **    HL7 Val (3): "_RACES("FDA",IEN,3)
  1.  ..S JUNK(8)="  **    CDC Val (4): "_RACES("FDA",IEN,4)
  1.  ..S JUNK(9)="  **    PTF Val (5): "_RACES("FDA",IEN,5)
  1.  ..S JUNK(10)="  **"
  1.  ..D MES^XPDUTL(.JUNK) K JUNK
  1.  ;Delete RACE identifier
  1.  S JUNK(1)=" "
  1.  S JUNK(2)="Removing old RACE field (#.06) as an identifier of the"
  1.  S JUNK(3)="PATIENT file (#2)."
  1.  S JUNK(4)=" "
  1.  D MES^XPDUTL(.JUNK) K JUNK
  1.  K ^DD(2,0,"ID",.06)
  1.  Q
  1.  ;
  1. BLDLST(ARRAY)   ;Build list of valid races
  1.  ;Input  : ARRAY - Array to place values into (pass by value)
  1.  ;Output : ARRAY("FDA",X,Field) = Value
  1.  ;Notes  : ARRAY will be initiallized (killed) on entry
  1.  ;       : Assumes ARRAY is input
  1.  ;
  1.  N LOOP,TEXT,STOP,X
  1.  K ARRAY
  1.  S (STOP,LOOP)=0
  1.  F  S LOOP=LOOP+1 D  Q:STOP
  1.  .S TEXT=$P($T(RACES+LOOP),";;",2)
  1.  .S X=$P(TEXT,"^",1)
  1.  .I X="" S STOP=1 Q
  1.  .S ARRAY("FDA",LOOP,.01)=X
  1.  .F X=2:1:5 S ARRAY("FDA",LOOP,X)=$P(TEXT,"^",X)
  1.  .S ARRAY("FDA",LOOP,200)="@"
  1.  .S ARRAY("FDA",LOOP,202)="@"
  1.  Q
  1.  ;
  1. RACES ;RACE (#.01)^ABBREVIATION (#2)^HL7 (#3)^CDC (#4)^PTF (#5)
  1.  ;;AMERICAN INDIAN OR ALASKA NATIVE^3^1002-5^1002-5^3
  1.  ;;ASIAN^A^2028-9^2028-9^8
  1.  ;;BLACK OR AFRICAN AMERICAN^B^2054-5^2054-5^9
  1.  ;;DECLINED TO ANSWER^D^0000-0^^C
  1.  ;;NATIVE HAWAIIAN OR OTHER PACIFIC ISLANDER^H^2076-8^2076-8^A
  1.  ;;UNKNOWN BY PATIENT^U^9999-4^^D
  1.  ;;WHITE^W^2106-3^2106-3^B
  1.  ;;