144 lines
4.8 KiB
Mathematica
144 lines
4.8 KiB
Mathematica
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
|
|
;;
|