- OOPSXV2 ;WIOFO/LLH-PRE INIT ROUTINE TO FIX FILE 2263.2 ;02/07/02
- ;;2.0;ASISTS;;Jun 03, 2002
- ; 2/7/2002 - Added fix for Table files to remove colon from name
- ; Cant use ^DIE-input transform prevents edits
- N MSG
- S MSG="Modifying ASISTS DOL CAUSE OF INJURY CODE Table File (#2263.2)"
- D BMES^XPDUTL(MSG) H 1
- D MES^XPDUTL(" ")
- N NA,NA2,IEN,CHG,DA,DIC,DIE,DR
- S IEN=0,DIC=2263.2
- F S IEN=$O(^OOPS(DIC,IEN)) Q:IEN'>0 D
- . S (NA,NA2)=$$GET1^DIQ(DIC,IEN,.01),CHG=""
- . I NA[":" S NA=$TR(NA,":","- "),CHG=1
- . I CHG="" Q
- . ; use NA2 for original name
- . S CODE=$$GET1^DIQ(DIC,IEN,1,"I")
- . K ^OOPS(DIC,"B",NA2,IEN)
- . K ^OOPS(DIC,"C",$E(CODE,1,3),IEN)
- . K ^OOPS(DIC,"D",$$UP^OOPSUTL4($E(NA2,1,30)),IEN)
- . ; use NA for new Name
- . S $P(^OOPS(DIC,IEN,0),U)=NA
- . S ^OOPS(DIC,"B",NA,IEN)=""
- . S ^OOPS(DIC,"C",$E(CODE,1,3),IEN)=""
- . S ^OOPS(DIC,"D",$$UP^OOPSUTL4($E(NA,1,30)),IEN)=""
- SRCCD ; Clean up 2 entries in OWCP Source Code table
- S MSG="Modifying ASISTS DOL SOURCE OF INJURY CODES Table File (#2263.1)"
- D BMES^XPDUTL(MSG) H 1
- D MES^XPDUTL(" ")
- I $P(^OOPS(2263.1,26,0),U)="Hand tool (powered: saw" D
- .S $P(^OOPS(2263.1,26,0),U)="Hand tool (powered saw)"
- .K ^OOPS(2263.1,"B","Hand tool (powered: saw",26)
- .S ^OOPS(2263.1,"B","Hand tool (powered saw)",26)=""
- .K ^OOPS(2263.1,"D","HAND TOOL (POWERED: SAW",26)
- .S ^OOPS(2263.1,"D","HAND TOOL (POWERED SAW)",26)=""
- I $P(^OOPS(2263.1,67,0),U)="Liquid Chemical:" D
- .S $P(^OOPS(2263.1,67,0),U)="Liquid Chemical"
- .K ^OOPS(2263.1,"B","Liquid Chemical:",67)
- .S ^OOPS(2263.1,"B","Liquid Chemical",67)=""
- .K ^OOPS(2263.1,"D","LIQUID CHEMICAL:",67)
- .S ^OOPS(2263.1,"D","LIQUID CHEMICAL",67)=""
- NOICD ; Clean up 3 entries in OWCP NOI code table
- S MSG="Modifying ASISTS DOL NATURE OF INJURY CODES Table File (#2263.3)"
- D BMES^XPDUTL(MSG) H 1
- D MES^XPDUTL(" ")
- I $P(^OOPS(2263.3,13,0),U)="GENERAL SYMPTOMS: SYNCOPE, DIZZINESS, VERTIGO, FATIGUE, NUMBNESS OF BODY PART" D
- .S $P(^OOPS(2263.3,13,0),U)="GENERAL SYMPTOMS- SYNCOPE, DIZZINESS, VERTIGO, FATIGUE, NUMBNESS OF BODY PART"
- .K ^OOPS(2263.3,"B","GENERAL SYMPTOMS: SYNCOPE, DIZZINESS, VERTIGO, FATIGUE, NUMBNESS OF BO",13)
- .S ^OOPS(2263.3,"B","GENERAL SYMPTOMS- SYNCOPE, DIZZINESS, VERTIGO, FATIGUE, NUMBNESS OF BO",13)=""
- .K ^OOPS(2263.3,"D","GENERAL SYMPTOMS: SYNCOPE, DIZ",13)
- .S ^OOPS(2263.3,"D","GENERAL SYMPTOMS- SYNCOPE, DIZ",13)=""
- I $P(^OOPS(2263.3,68,0),U)="SKIN CONDITIONS: ALLERGY, ECZEMA, DERMATITIS" D
- .S $P(^OOPS(2263.3,68,0),U)="SKIN CONDITIONS- ALLERGY, ECZEMA, DERMATITIS"
- .K ^OOPS(2263.3,"B","SKIN CONDITIONS: ALLERGY, ECZEMA, DERMATITIS",68)
- .S ^OOPS(2263.3,"B","SKIN CONDITIONS- ALLERGY, ECZEMA, DERMATITIS",68)=""
- .K ^OOPS(2263.3,"D","SKIN CONDITIONS: ALLERGY, ECZE",68)
- .S ^OOPS(2263.3,"D","SKIN CONDITIONS- ALLERGY, ECZE",68)=""
- I $P(^OOPS(2263.3,83,0),U)="INFECTIOUS DISEASES: BACTERIA, VIRUSES, PARASITES" D
- .S $P(^OOPS(2263.3,83,0),U)="INFECTIOUS DISEASES- BACTERIA, VIRUSES, PARASITES"
- .K ^OOPS(2263.3,"B","INFECTIOUS DISEASES: BACTERIA, VIRUSES, PARASITES",83)
- .S ^OOPS(2263.3,"B","INFECTIOUS DISEASES- BACTERIA, VIRUSES, PARASITES",83)=""
- .K ^OOPS(2263.3,"D","INFECTIOUS DISEASES: BACTERIA,",83)
- .S ^OOPS(2263.3,"D","INFECTIOUS DISEASES- BACTERIA,",83)=""
- D BMES^XPDUTL("Table updates complete.")
- Q
- BODYPTS ;
- N DA,DIK,DIC,DIE,DR,FLG,BODY,BODY1,IEN,STR
- I $D(^OOPS(2261.1,5,0)) S DA=5,DIK="^OOPS(2261.1," D ^DIK
- I $$GET1^DIQ(2261.1,101,.01)'="INTESTINES" D
- .S (DIC,DIE)="^OOPS(2261.1,",DA=101,DR=".01////INTESTINES" D ^DIE
- ; now make sure no ASISTS Records with a pointer = 5 in field 30, 30.1
- S IEN=0
- F S IEN=$O(^OOPS(2260,IEN)) Q:IEN'>0 D
- .S STR=$G(^OOPS(2260,IEN,"2162B")),FLG=0
- .I $P($G(STR),U,4)=5 S $P(STR,U,4)=101,FLG=1
- .I $P($G(STR),U,8)=5 S $P(STR,U,8)=101,FLG=1
- .I FLG S ^OOPS(2260,IEN,"2162B")=STR
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOOPSXV2 3872 printed Mar 13, 2025@20:44:39 Page 2
- OOPSXV2 ;WIOFO/LLH-PRE INIT ROUTINE TO FIX FILE 2263.2 ;02/07/02
- +1 ;;2.0;ASISTS;;Jun 03, 2002
- +2 ; 2/7/2002 - Added fix for Table files to remove colon from name
- +3 ; Cant use ^DIE-input transform prevents edits
- +4 NEW MSG
- +5 SET MSG="Modifying ASISTS DOL CAUSE OF INJURY CODE Table File (#2263.2)"
- +6 DO BMES^XPDUTL(MSG)
- HANG 1
- +7 DO MES^XPDUTL(" ")
- +8 NEW NA,NA2,IEN,CHG,DA,DIC,DIE,DR
- +9 SET IEN=0
- SET DIC=2263.2
- +10 FOR
- SET IEN=$ORDER(^OOPS(DIC,IEN))
- if IEN'>0
- QUIT
- Begin DoDot:1
- +11 SET (NA,NA2)=$$GET1^DIQ(DIC,IEN,.01)
- SET CHG=""
- +12 IF NA[":"
- SET NA=$TRANSLATE(NA,":","- ")
- SET CHG=1
- +13 IF CHG=""
- QUIT
- +14 ; use NA2 for original name
- +15 SET CODE=$$GET1^DIQ(DIC,IEN,1,"I")
- +16 KILL ^OOPS(DIC,"B",NA2,IEN)
- +17 KILL ^OOPS(DIC,"C",$EXTRACT(CODE,1,3),IEN)
- +18 KILL ^OOPS(DIC,"D",$$UP^OOPSUTL4($EXTRACT(NA2,1,30)),IEN)
- +19 ; use NA for new Name
- +20 SET $PIECE(^OOPS(DIC,IEN,0),U)=NA
- +21 SET ^OOPS(DIC,"B",NA,IEN)=""
- +22 SET ^OOPS(DIC,"C",$EXTRACT(CODE,1,3),IEN)=""
- +23 SET ^OOPS(DIC,"D",$$UP^OOPSUTL4($EXTRACT(NA,1,30)),IEN)=""
- End DoDot:1
- SRCCD ; Clean up 2 entries in OWCP Source Code table
- +1 SET MSG="Modifying ASISTS DOL SOURCE OF INJURY CODES Table File (#2263.1)"
- +2 DO BMES^XPDUTL(MSG)
- HANG 1
- +3 DO MES^XPDUTL(" ")
- +4 IF $PIECE(^OOPS(2263.1,26,0),U)="Hand tool (powered: saw"
- Begin DoDot:1
- +5 SET $PIECE(^OOPS(2263.1,26,0),U)="Hand tool (powered saw)"
- +6 KILL ^OOPS(2263.1,"B","Hand tool (powered: saw",26)
- +7 SET ^OOPS(2263.1,"B","Hand tool (powered saw)",26)=""
- +8 KILL ^OOPS(2263.1,"D","HAND TOOL (POWERED: SAW",26)
- +9 SET ^OOPS(2263.1,"D","HAND TOOL (POWERED SAW)",26)=""
- End DoDot:1
- +10 IF $PIECE(^OOPS(2263.1,67,0),U)="Liquid Chemical:"
- Begin DoDot:1
- +11 SET $PIECE(^OOPS(2263.1,67,0),U)="Liquid Chemical"
- +12 KILL ^OOPS(2263.1,"B","Liquid Chemical:",67)
- +13 SET ^OOPS(2263.1,"B","Liquid Chemical",67)=""
- +14 KILL ^OOPS(2263.1,"D","LIQUID CHEMICAL:",67)
- +15 SET ^OOPS(2263.1,"D","LIQUID CHEMICAL",67)=""
- End DoDot:1
- NOICD ; Clean up 3 entries in OWCP NOI code table
- +1 SET MSG="Modifying ASISTS DOL NATURE OF INJURY CODES Table File (#2263.3)"
- +2 DO BMES^XPDUTL(MSG)
- HANG 1
- +3 DO MES^XPDUTL(" ")
- +4 IF $PIECE(^OOPS(2263.3,13,0),U)="GENERAL SYMPTOMS: SYNCOPE, DIZZINESS, VERTIGO, FATIGUE, NUMBNESS OF BODY PART"
- Begin DoDot:1
- +5 SET $PIECE(^OOPS(2263.3,13,0),U)="GENERAL SYMPTOMS- SYNCOPE, DIZZINESS, VERTIGO, FATIGUE, NUMBNESS OF BODY PART"
- +6 KILL ^OOPS(2263.3,"B","GENERAL SYMPTOMS: SYNCOPE, DIZZINESS, VERTIGO, FATIGUE, NUMBNESS OF BO",13)
- +7 SET ^OOPS(2263.3,"B","GENERAL SYMPTOMS- SYNCOPE, DIZZINESS, VERTIGO, FATIGUE, NUMBNESS OF BO",13)=""
- +8 KILL ^OOPS(2263.3,"D","GENERAL SYMPTOMS: SYNCOPE, DIZ",13)
- +9 SET ^OOPS(2263.3,"D","GENERAL SYMPTOMS- SYNCOPE, DIZ",13)=""
- End DoDot:1
- +10 IF $PIECE(^OOPS(2263.3,68,0),U)="SKIN CONDITIONS: ALLERGY, ECZEMA, DERMATITIS"
- Begin DoDot:1
- +11 SET $PIECE(^OOPS(2263.3,68,0),U)="SKIN CONDITIONS- ALLERGY, ECZEMA, DERMATITIS"
- +12 KILL ^OOPS(2263.3,"B","SKIN CONDITIONS: ALLERGY, ECZEMA, DERMATITIS",68)
- +13 SET ^OOPS(2263.3,"B","SKIN CONDITIONS- ALLERGY, ECZEMA, DERMATITIS",68)=""
- +14 KILL ^OOPS(2263.3,"D","SKIN CONDITIONS: ALLERGY, ECZE",68)
- +15 SET ^OOPS(2263.3,"D","SKIN CONDITIONS- ALLERGY, ECZE",68)=""
- End DoDot:1
- +16 IF $PIECE(^OOPS(2263.3,83,0),U)="INFECTIOUS DISEASES: BACTERIA, VIRUSES, PARASITES"
- Begin DoDot:1
- +17 SET $PIECE(^OOPS(2263.3,83,0),U)="INFECTIOUS DISEASES- BACTERIA, VIRUSES, PARASITES"
- +18 KILL ^OOPS(2263.3,"B","INFECTIOUS DISEASES: BACTERIA, VIRUSES, PARASITES",83)
- +19 SET ^OOPS(2263.3,"B","INFECTIOUS DISEASES- BACTERIA, VIRUSES, PARASITES",83)=""
- +20 KILL ^OOPS(2263.3,"D","INFECTIOUS DISEASES: BACTERIA,",83)
- +21 SET ^OOPS(2263.3,"D","INFECTIOUS DISEASES- BACTERIA,",83)=""
- End DoDot:1
- +22 DO BMES^XPDUTL("Table updates complete.")
- +23 QUIT
- BODYPTS ;
- +1 NEW DA,DIK,DIC,DIE,DR,FLG,BODY,BODY1,IEN,STR
- +2 IF $DATA(^OOPS(2261.1,5,0))
- SET DA=5
- SET DIK="^OOPS(2261.1,"
- DO ^DIK
- +3 IF $$GET1^DIQ(2261.1,101,.01)'="INTESTINES"
- Begin DoDot:1
- +4 SET (DIC,DIE)="^OOPS(2261.1,"
- SET DA=101
- SET DR=".01////INTESTINES"
- DO ^DIE
- End DoDot:1
- +5 ; now make sure no ASISTS Records with a pointer = 5 in field 30, 30.1
- +6 SET IEN=0
- +7 FOR
- SET IEN=$ORDER(^OOPS(2260,IEN))
- if IEN'>0
- QUIT
- Begin DoDot:1
- +8 SET STR=$GET(^OOPS(2260,IEN,"2162B"))
- SET FLG=0
- +9 IF $PIECE($GET(STR),U,4)=5
- SET $PIECE(STR,U,4)=101
- SET FLG=1
- +10 IF $PIECE($GET(STR),U,8)=5
- SET $PIECE(STR,U,8)=101
- SET FLG=1
- +11 IF FLG
- SET ^OOPS(2260,IEN,"2162B")=STR
- End DoDot:1
- +12 QUIT
