- DG53657P ;BAJ - Patch DG*5.3*657 Pre-Install Utility Routine ; 10/24/2006
- ;;5.3;Registration;**657**;AUG 13, 1993;Build 19
- Q
- ;
- ;
- EN N XPDABORT
- D LKUP(61,"MISSING PHONE NUMBER DATA","C")
- ;2 - consistency check not there, 3 - consistency check is wrong
- I ($G(XPDABORT)=2)!($G(XPDABORT)=3) Q ;Find file 38.6 entry
- D LKUP(87,"SC ELIG BUT NO RD CODES","A")
- Q:$G(XPDABORT)=3
- D POSTN ;Modify file 38.6 entry
- D CREATE ;add the 87 consistency check
- D COMPILE
- Q
- ;
- LKUP(RULE,FIELD01,MODE) ; Update entry in INCONSISTENT DATA ELEMENTS file (#38.6)
- ;MODE = 'C' change
- ;MODE = 'A' add
- N ERR,DA,DIE,DR,X
- K XPDABORT
- D BMES^XPDUTL("Checking entry #"_RULE_" in 38.6 file.")
- S DIE=38.6,DA=$$FIND1^DIC(DIE,"","X",RULE)
- I 'DA,MODE="C" D Q
- . S XPDABORT=2
- . D MES^XPDUTL(" *** Entry not found! ***")
- . D BMES^XPDUTL(" *** Please contact EVS for assistance ***")
- . D BMES^XPDUTL(" *** INSTALLATION ABORTED ***")
- . D BMES^XPDUTL("")
- . Q
- S X=""
- I $G(DA)'="" S X=$G(^DGIN(38.6,DA,0))
- I X'="",$P(X,"^",1)'=FIELD01 D Q
- . S XPDABORT=3
- . D MES^XPDUTL(" *** Field #.01 should be "_FIELD01_"! ***")
- . D BMES^XPDUTL(" *** Please contact EVS for assistance ***")
- . D BMES^XPDUTL(" *** INSTALLATION ABORTED ***")
- . D BMES^XPDUTL("")
- . Q
- Q
- POSTN ; Update entry in INCONSISTENT DATA ELEMENTS file (#38.6)
- N FILE,IENS,FIELD,DGWP,ERRORS,FDA
- D BMES^XPDUTL("Updating Consistency #61")
- ;FDA_ROOT(FILE#,"IENS",FIELD#)="VALUE"
- S FILE=38.6,IENS="61,",FIELD=50
- S DGWP(1,0)="Inconsistency results if the patient's Employment Status is EMPLOYED FULL"
- S DGWP(2,0)="TIME, EMPLOYED PART TIME, or SELF EMPLOYED and the PHONE NUMBER [WORK] has"
- S DGWP(3,0)="not been entered."
- S FDA(FILE,IENS,FIELD)="DGWP"
- D FILE^DIE("K","FDA","ERRORS(1)")
- I $D(ERRORS) D Q
- . D MES^XPDUTL(" *** Error filing Data Dictionary update! ***")
- . D BMES^XPDUTL(" *** Please contact EVS for assistance ***")
- . D BMES^XPDUTL(" *** INSTALLATION ABORTED ***")
- . D BMES^XPDUTL("")
- . Q
- D MES^XPDUTL(" *** Update Complete ***")
- D BMES^XPDUTL("")
- Q
- ;
- CREATE ;Post-Install
- N MSGROOT,FDAWP,FDAROOT,IENROOT,IEN,X,ERR,LN,LN2
- S X=$G(^DGIN(38.6,87,0))
- I $L(X),$P(X,"^",1)'="SC ELIG BUT NO RD CODES" D Q
- . D BMES^XPDUTL("An entry already exists in file 38.6 for consistency #87.")
- . D MES^XPDUTL("Cannot add SC ELIG BUT NO RD CODES.")
- . Q
- I $L(X),$P(X,"^",1)="SC ELIG BUT NO RD CODES" Q
- D BMES^XPDUTL("Adding Consistency #87")
- S IEN="+1,"
- S FDAROOT(38.6,IEN,.01)="SC ELIG BUT NO RD CODES"
- S FDAROOT(38.6,IEN,2)="SC ELIGIBILITY BUT NO RATED DISABILITY CODES"
- S FDAROOT(38.6,IEN,50)="FDAWP"
- S FDAWP(1,0)="Inconsistency results if the PRIMARY ELIGIBILITY CODE"
- S FDAWP(2,0)="is a 1 (SERVICE CONNECTED 50% TO 100%) or a 3 (SC LESS THAN 50%)"
- S FDAWP(3,0)="and no rated disabilities are present."
- S FDAROOT(38.6,IEN,3)="NO KEY REQUIRED"
- S FDAROOT(38.6,IEN,5)="CHECK"
- S IENROOT(1)=87
- D UPDATE^DIE("E","FDAROOT","IENROOT","MSGROOT")
- I $D(MSGROOT("DIERR")) D Q
- . S (ERR,LN2)=0
- . D ERR
- . D BMES^XPDUTL(.X)
- . Q
- D MES^XPDUTL(" *** CC #87 Added ***")
- D BMES^XPDUTL("")
- Q
- ERR F S ERR=+$O(MSGROOT("DIERR",ERR)) Q:'ERR D LN
- Q
- LN S LN=0
- F S LN=+$O(MSGROOT("DIERR",ERR,"TEXT",LN)) Q:'LN D
- . S LN2=LN2+1
- . S X(LN2)=MSGROOT("DIERR",ERR,"TEXT",LN)
- . Q
- Q
- COMPILE ;compile screen 7
- D BMES^XPDUTL("Re-compiling input template DG LOAD EDIT SCREEN 7 of PATIENT FILE(#2)")
- N X,Y,DMAX
- S Y=$O(^DIE("B","DG LOAD EDIT SCREEN 7",""))
- I Y'="" D
- . S X=$G(^DIE(Y,"ROU")) I $E(X)="^" S X=$E(X,2,99)
- . S DMAX=$$ROUSIZE^DILF
- . D EN^DIEZ
- . Q
- D BMES^XPDUTL("Re-compiling input template DVBHINQ UPDATE of PATIENT FILOE(#2)")
- S Y=$O(^DIE("B","DVBHINQ UPDATE",""))
- I Y'="" D
- . S X=$G(^DIE(Y,"ROU")) I $E(X)="^" S X=$E(X,2,99)
- . S DMAX=$$ROUSIZE^DILF
- . D EN^DIEZ
- . Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53657P 3895 printed Jan 18, 2025@03:38:50 Page 2
- DG53657P ;BAJ - Patch DG*5.3*657 Pre-Install Utility Routine ; 10/24/2006
- +1 ;;5.3;Registration;**657**;AUG 13, 1993;Build 19
- +2 QUIT
- +3 ;
- +4 ;
- EN NEW XPDABORT
- +1 DO LKUP(61,"MISSING PHONE NUMBER DATA","C")
- +2 ;2 - consistency check not there, 3 - consistency check is wrong
- +3 ;Find file 38.6 entry
- IF ($GET(XPDABORT)=2)!($GET(XPDABORT)=3)
- QUIT
- +4 DO LKUP(87,"SC ELIG BUT NO RD CODES","A")
- +5 if $GET(XPDABORT)=3
- QUIT
- +6 ;Modify file 38.6 entry
- DO POSTN
- +7 ;add the 87 consistency check
- DO CREATE
- +8 DO COMPILE
- +9 QUIT
- +10 ;
- LKUP(RULE,FIELD01,MODE) ; Update entry in INCONSISTENT DATA ELEMENTS file (#38.6)
- +1 ;MODE = 'C' change
- +2 ;MODE = 'A' add
- +3 NEW ERR,DA,DIE,DR,X
- +4 KILL XPDABORT
- +5 DO BMES^XPDUTL("Checking entry #"_RULE_" in 38.6 file.")
- +6 SET DIE=38.6
- SET DA=$$FIND1^DIC(DIE,"","X",RULE)
- +7 IF 'DA
- IF MODE="C"
- Begin DoDot:1
- +8 SET XPDABORT=2
- +9 DO MES^XPDUTL(" *** Entry not found! ***")
- +10 DO BMES^XPDUTL(" *** Please contact EVS for assistance ***")
- +11 DO BMES^XPDUTL(" *** INSTALLATION ABORTED ***")
- +12 DO BMES^XPDUTL("")
- +13 QUIT
- End DoDot:1
- QUIT
- +14 SET X=""
- +15 IF $GET(DA)'=""
- SET X=$GET(^DGIN(38.6,DA,0))
- +16 IF X'=""
- IF $PIECE(X,"^",1)'=FIELD01
- Begin DoDot:1
- +17 SET XPDABORT=3
- +18 DO MES^XPDUTL(" *** Field #.01 should be "_FIELD01_"! ***")
- +19 DO BMES^XPDUTL(" *** Please contact EVS for assistance ***")
- +20 DO BMES^XPDUTL(" *** INSTALLATION ABORTED ***")
- +21 DO BMES^XPDUTL("")
- +22 QUIT
- End DoDot:1
- QUIT
- +23 QUIT
- POSTN ; Update entry in INCONSISTENT DATA ELEMENTS file (#38.6)
- +1 NEW FILE,IENS,FIELD,DGWP,ERRORS,FDA
- +2 DO BMES^XPDUTL("Updating Consistency #61")
- +3 ;FDA_ROOT(FILE#,"IENS",FIELD#)="VALUE"
- +4 SET FILE=38.6
- SET IENS="61,"
- SET FIELD=50
- +5 SET DGWP(1,0)="Inconsistency results if the patient's Employment Status is EMPLOYED FULL"
- +6 SET DGWP(2,0)="TIME, EMPLOYED PART TIME, or SELF EMPLOYED and the PHONE NUMBER [WORK] has"
- +7 SET DGWP(3,0)="not been entered."
- +8 SET FDA(FILE,IENS,FIELD)="DGWP"
- +9 DO FILE^DIE("K","FDA","ERRORS(1)")
- +10 IF $DATA(ERRORS)
- Begin DoDot:1
- +11 DO MES^XPDUTL(" *** Error filing Data Dictionary update! ***")
- +12 DO BMES^XPDUTL(" *** Please contact EVS for assistance ***")
- +13 DO BMES^XPDUTL(" *** INSTALLATION ABORTED ***")
- +14 DO BMES^XPDUTL("")
- +15 QUIT
- End DoDot:1
- QUIT
- +16 DO MES^XPDUTL(" *** Update Complete ***")
- +17 DO BMES^XPDUTL("")
- +18 QUIT
- +19 ;
- CREATE ;Post-Install
- +1 NEW MSGROOT,FDAWP,FDAROOT,IENROOT,IEN,X,ERR,LN,LN2
- +2 SET X=$GET(^DGIN(38.6,87,0))
- +3 IF $LENGTH(X)
- IF $PIECE(X,"^",1)'="SC ELIG BUT NO RD CODES"
- Begin DoDot:1
- +4 DO BMES^XPDUTL("An entry already exists in file 38.6 for consistency #87.")
- +5 DO MES^XPDUTL("Cannot add SC ELIG BUT NO RD CODES.")
- +6 QUIT
- End DoDot:1
- QUIT
- +7 IF $LENGTH(X)
- IF $PIECE(X,"^",1)="SC ELIG BUT NO RD CODES"
- QUIT
- +8 DO BMES^XPDUTL("Adding Consistency #87")
- +9 SET IEN="+1,"
- +10 SET FDAROOT(38.6,IEN,.01)="SC ELIG BUT NO RD CODES"
- +11 SET FDAROOT(38.6,IEN,2)="SC ELIGIBILITY BUT NO RATED DISABILITY CODES"
- +12 SET FDAROOT(38.6,IEN,50)="FDAWP"
- +13 SET FDAWP(1,0)="Inconsistency results if the PRIMARY ELIGIBILITY CODE"
- +14 SET FDAWP(2,0)="is a 1 (SERVICE CONNECTED 50% TO 100%) or a 3 (SC LESS THAN 50%)"
- +15 SET FDAWP(3,0)="and no rated disabilities are present."
- +16 SET FDAROOT(38.6,IEN,3)="NO KEY REQUIRED"
- +17 SET FDAROOT(38.6,IEN,5)="CHECK"
- +18 SET IENROOT(1)=87
- +19 DO UPDATE^DIE("E","FDAROOT","IENROOT","MSGROOT")
- +20 IF $DATA(MSGROOT("DIERR"))
- Begin DoDot:1
- +21 SET (ERR,LN2)=0
- +22 DO ERR
- +23 DO BMES^XPDUTL(.X)
- +24 QUIT
- End DoDot:1
- QUIT
- +25 DO MES^XPDUTL(" *** CC #87 Added ***")
- +26 DO BMES^XPDUTL("")
- +27 QUIT
- ERR FOR
- SET ERR=+$ORDER(MSGROOT("DIERR",ERR))
- if 'ERR
- QUIT
- DO LN
- +1 QUIT
- LN SET LN=0
- +1 FOR
- SET LN=+$ORDER(MSGROOT("DIERR",ERR,"TEXT",LN))
- if 'LN
- QUIT
- Begin DoDot:1
- +2 SET LN2=LN2+1
- +3 SET X(LN2)=MSGROOT("DIERR",ERR,"TEXT",LN)
- +4 QUIT
- End DoDot:1
- +5 QUIT
- COMPILE ;compile screen 7
- +1 DO BMES^XPDUTL("Re-compiling input template DG LOAD EDIT SCREEN 7 of PATIENT FILE(#2)")
- +2 NEW X,Y,DMAX
- +3 SET Y=$ORDER(^DIE("B","DG LOAD EDIT SCREEN 7",""))
- +4 IF Y'=""
- Begin DoDot:1
- +5 SET X=$GET(^DIE(Y,"ROU"))
- IF $EXTRACT(X)="^"
- SET X=$EXTRACT(X,2,99)
- +6 SET DMAX=$$ROUSIZE^DILF
- +7 DO EN^DIEZ
- +8 QUIT
- End DoDot:1
- +9 DO BMES^XPDUTL("Re-compiling input template DVBHINQ UPDATE of PATIENT FILOE(#2)")
- +10 SET Y=$ORDER(^DIE("B","DVBHINQ UPDATE",""))
- +11 IF Y'=""
- Begin DoDot:1
- +12 SET X=$GET(^DIE(Y,"ROU"))
- IF $EXTRACT(X)="^"
- SET X=$EXTRACT(X,2,99)
- +13 SET DMAX=$$ROUSIZE^DILF
- +14 DO EN^DIEZ
- +15 QUIT
- End DoDot:1
- +16 QUIT