- ECX3P191 ;MNTVBB/DTA - NATIONAL CLINIC (#728.441) File Update; JULY 15, 2024@16:44
- ;;3.0;DSS EXTRACTS;**191**;Dec 22, 1997;Build 3
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ; This routine is used as a post-init in a KIDS build to
- ; update the NATIONAL CLINIC (#728.441) file for FY25.
- ;
- ; Reference(s) to $$FIND1^DIC supported by ICR# 2051
- ; Reference(s) to FILE^DIE supported by ICR# 2053
- ; Reference(s) to UPDATE^DIE supported by ICR# 2053
- ; Reference(s) to BMES^XPDUTL supported by ICR# 10141
- ; Reference(s) to MES^XPDUTL supported by ICR# 10141
- ;
- Q
- ;
- POST ;routine entry point
- ;
- ; Start of Install
- D BMES^XPDUTL("Update NATIONAL CLINIC (#728.441) file starts.")
- ;D ADD ;add new code
- N ECX191FILES
- S ECX191FILE=""
- S ECX191FILES="728.441"
- S ECXCNT=0
- F ECXCNT=1:1:$L(ECX191FILES,"^") D
- . S ECX191FILE=$P(ECX191FILES,"^",ECXCNT)
- . D GLBBKUP
- . Q
- ;
- D UPDATE ;change short description of existing clinic codes
- D BMES^XPDUTL("Update complete.")
- D MES^XPDUTL("")
- ;
- Q
- ;
- ADD ; Add new code
- ;
- N ECXI,ECXREC,ECXNM,ECXCODE,ECXIEN,ECXERR
- D BMES^XPDUTL(">>> Adding new CHAR4 code(s) to the NATIONAL CLINIC file (#728.441)...")
- ;
- F ECXI=1:1 S ECXREC=$P($T(ADDCLIN+ECXI),";;",2) Q:ECXREC="QUIT" D
- . S ECXNM=$P(ECXREC,U) ;Name
- . S ECXCODE=$P(ECXREC,U,2) ;Code
- . ; check if new code already exists in file 728.441
- . S ECXIEN=$$FIND1^DIC(728.441,"","X",ECXCODE,"","","ECXERR")
- . ; quit if error
- . I $D(ECXERR) D Q
- . . D BMES^XPDUTL(" >> ... Unable to add CHAR4 code "_ECXCODE_" - "_ECXNM_" to file.")
- . . D MES^XPDUTL(" >> ... "_$G(ECXERR("DIERR",1,"TEXT",1))_".")
- . . D MES^XPDUTL(" >> ... Please contact support for assistance...")
- . . K ECXERR
- . ; if code already exists, quit
- . I ECXIEN D Q
- . . D BMES^XPDUTL(" >> CHAR4 code "_ECXCODE_" - "_ECXNM_" already exists.")
- . ; if code does not exist, add new entry
- . ; set field values of new entry
- . K ECXFDA
- . S ECXFDA(728.441,"+1,",.01)=ECXCODE
- . S ECXFDA(728.441,"+1,",1)=ECXNM
- . ; add new entry
- . D UPDATE^DIE("E","ECXFDA","","ECXERR")
- . ; check if error
- . I '$D(ECXERR) D
- . . D BMES^XPDUTL(" >> CHAR4 Code "_ECXCODE_" - "_ECXNM_" added to file.")
- . I $D(ECXERR) D
- . . D BMES^XPDUTL(" >> ... Unable to add CHAR4 code "_ECXCODE_" "_ECXNM_" to file.")
- . . D MES^XPDUTL(" >> ... "_$G(ECXERR("DIERR",1,"TEXT",1))_".")
- . . D MES^XPDUTL(" >> ... Please contact support for assistance.")
- . . ; clean out error array b4 processing next code
- . . K ECXERR
- ;
- D BMES^XPDUTL(">>> Add new CHAR4 code(s) complete.")
- D MES^XPDUTL("")
- Q
- ;
- UPDATE ;changing short description of existing entries
- ;ECXREC is in format: code^short description
- ;
- N ECXCODE,ECXDESC,ECXIEN,DIE,DA,DR,ECXI,ECXREC,ECXERR
- ;
- D BMES^XPDUTL(">>> Updating entries in the NATIONAL CLINIC (728.441) file...")
- ;
- F ECXI=1:1 S ECXREC=$P($T(UPDCLIN+ECXI),";;",2) Q:ECXREC="QUIT" D
- .S ECXCODE=$P(ECXREC,"^"),ECXDESC=$P(ECXREC,"^",2)
- .S ECXIEN=$$FIND1^DIC(728.441,"","X",ECXCODE,"","","ECXERR")
- .I 'ECXIEN D Q
- ..D BMES^XPDUTL(">>>....Unable to find code: "_ECXCODE_".")
- ..D BMES^XPDUTL("*** Please contact support for assistance. ***")
- .K FDA
- .S FDA(728.441,ECXIEN_",",1)=ECXDESC
- .D FILE^DIE(,"FDA","ECXERR")
- .I '$D(ECXERR) D BMES^XPDUTL(">>>...."_ECXCODE_" - "_$P(ECXREC,U,2)_" updated")
- .I $D(ECXERR) D BMES^XPDUTL(">>>....Unable to update code "_ECXCODE_".") D
- ..D BMES^XPDUTL("*** Please contact support for assistance. ***")
- ;
- Q
- ;
- GLBBKUP ; XTMP Backup of file(s)
- S ECXBKUPNDE="ECX*3*191-Update NATIONAL CLINIC FY25 Char4 (#728.441)"
- S ^XTMP("ECX3P191",0)=$$FMADD^XLFDT(DT,120)_"^"_DT_"^"_ECXBKUPNDE
- M ^XTMP("ECX3P191",ECX191FILE,$H)=^ECX(ECX191FILE)
- Q
- ;
- ADDCLIN ;Add new code
- ;
- ;
- UPDCLIN ;Contains the NATIONAL CLINIC entry description to be updated
- ;;CDEC^CRH State Veterans Home (for Cleland Dole Pilot)
- ;;HTWC^Welch Allyn BP Machines
- ;;JCBC^Boothless Audiometry Clinic
- ;;MPAL^My Life My Story Program
- ;;WCRC^CRH Provider Type Not Assigned to other Char4
- ;;QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECX3P191 4150 printed Feb 18, 2025@23:17:08 Page 2
- ECX3P191 ;MNTVBB/DTA - NATIONAL CLINIC (#728.441) File Update; JULY 15, 2024@16:44
- +1 ;;3.0;DSS EXTRACTS;**191**;Dec 22, 1997;Build 3
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ; This routine is used as a post-init in a KIDS build to
- +5 ; update the NATIONAL CLINIC (#728.441) file for FY25.
- +6 ;
- +7 ; Reference(s) to $$FIND1^DIC supported by ICR# 2051
- +8 ; Reference(s) to FILE^DIE supported by ICR# 2053
- +9 ; Reference(s) to UPDATE^DIE supported by ICR# 2053
- +10 ; Reference(s) to BMES^XPDUTL supported by ICR# 10141
- +11 ; Reference(s) to MES^XPDUTL supported by ICR# 10141
- +12 ;
- +13 QUIT
- +14 ;
- POST ;routine entry point
- +1 ;
- +2 ; Start of Install
- +3 DO BMES^XPDUTL("Update NATIONAL CLINIC (#728.441) file starts.")
- +4 ;D ADD ;add new code
- +5 NEW ECX191FILES
- +6 SET ECX191FILE=""
- +7 SET ECX191FILES="728.441"
- +8 SET ECXCNT=0
- +9 FOR ECXCNT=1:1:$LENGTH(ECX191FILES,"^")
- Begin DoDot:1
- +10 SET ECX191FILE=$PIECE(ECX191FILES,"^",ECXCNT)
- +11 DO GLBBKUP
- +12 QUIT
- End DoDot:1
- +13 ;
- +14 ;change short description of existing clinic codes
- DO UPDATE
- +15 DO BMES^XPDUTL("Update complete.")
- +16 DO MES^XPDUTL("")
- +17 ;
- +18 QUIT
- +19 ;
- ADD ; Add new code
- +1 ;
- +2 NEW ECXI,ECXREC,ECXNM,ECXCODE,ECXIEN,ECXERR
- +3 DO BMES^XPDUTL(">>> Adding new CHAR4 code(s) to the NATIONAL CLINIC file (#728.441)...")
- +4 ;
- +5 FOR ECXI=1:1
- SET ECXREC=$PIECE($TEXT(ADDCLIN+ECXI),";;",2)
- if ECXREC="QUIT"
- QUIT
- Begin DoDot:1
- +6 ;Name
- SET ECXNM=$PIECE(ECXREC,U)
- +7 ;Code
- SET ECXCODE=$PIECE(ECXREC,U,2)
- +8 ; check if new code already exists in file 728.441
- +9 SET ECXIEN=$$FIND1^DIC(728.441,"","X",ECXCODE,"","","ECXERR")
- +10 ; quit if error
- +11 IF $DATA(ECXERR)
- Begin DoDot:2
- +12 DO BMES^XPDUTL(" >> ... Unable to add CHAR4 code "_ECXCODE_" - "_ECXNM_" to file.")
- +13 DO MES^XPDUTL(" >> ... "_$GET(ECXERR("DIERR",1,"TEXT",1))_".")
- +14 DO MES^XPDUTL(" >> ... Please contact support for assistance...")
- +15 KILL ECXERR
- End DoDot:2
- QUIT
- +16 ; if code already exists, quit
- +17 IF ECXIEN
- Begin DoDot:2
- +18 DO BMES^XPDUTL(" >> CHAR4 code "_ECXCODE_" - "_ECXNM_" already exists.")
- End DoDot:2
- QUIT
- +19 ; if code does not exist, add new entry
- +20 ; set field values of new entry
- +21 KILL ECXFDA
- +22 SET ECXFDA(728.441,"+1,",.01)=ECXCODE
- +23 SET ECXFDA(728.441,"+1,",1)=ECXNM
- +24 ; add new entry
- +25 DO UPDATE^DIE("E","ECXFDA","","ECXERR")
- +26 ; check if error
- +27 IF '$DATA(ECXERR)
- Begin DoDot:2
- +28 DO BMES^XPDUTL(" >> CHAR4 Code "_ECXCODE_" - "_ECXNM_" added to file.")
- End DoDot:2
- +29 IF $DATA(ECXERR)
- Begin DoDot:2
- +30 DO BMES^XPDUTL(" >> ... Unable to add CHAR4 code "_ECXCODE_" "_ECXNM_" to file.")
- +31 DO MES^XPDUTL(" >> ... "_$GET(ECXERR("DIERR",1,"TEXT",1))_".")
- +32 DO MES^XPDUTL(" >> ... Please contact support for assistance.")
- +33 ; clean out error array b4 processing next code
- +34 KILL ECXERR
- End DoDot:2
- End DoDot:1
- +35 ;
- +36 DO BMES^XPDUTL(">>> Add new CHAR4 code(s) complete.")
- +37 DO MES^XPDUTL("")
- +38 QUIT
- +39 ;
- UPDATE ;changing short description of existing entries
- +1 ;ECXREC is in format: code^short description
- +2 ;
- +3 NEW ECXCODE,ECXDESC,ECXIEN,DIE,DA,DR,ECXI,ECXREC,ECXERR
- +4 ;
- +5 DO BMES^XPDUTL(">>> Updating entries in the NATIONAL CLINIC (728.441) file...")
- +6 ;
- +7 FOR ECXI=1:1
- SET ECXREC=$PIECE($TEXT(UPDCLIN+ECXI),";;",2)
- if ECXREC="QUIT"
- QUIT
- Begin DoDot:1
- +8 SET ECXCODE=$PIECE(ECXREC,"^")
- SET ECXDESC=$PIECE(ECXREC,"^",2)
- +9 SET ECXIEN=$$FIND1^DIC(728.441,"","X",ECXCODE,"","","ECXERR")
- +10 IF 'ECXIEN
- Begin DoDot:2
- +11 DO BMES^XPDUTL(">>>....Unable to find code: "_ECXCODE_".")
- +12 DO BMES^XPDUTL("*** Please contact support for assistance. ***")
- End DoDot:2
- QUIT
- +13 KILL FDA
- +14 SET FDA(728.441,ECXIEN_",",1)=ECXDESC
- +15 DO FILE^DIE(,"FDA","ECXERR")
- +16 IF '$DATA(ECXERR)
- DO BMES^XPDUTL(">>>...."_ECXCODE_" - "_$PIECE(ECXREC,U,2)_" updated")
- +17 IF $DATA(ECXERR)
- DO BMES^XPDUTL(">>>....Unable to update code "_ECXCODE_".")
- Begin DoDot:2
- +18 DO BMES^XPDUTL("*** Please contact support for assistance. ***")
- End DoDot:2
- End DoDot:1
- +19 ;
- +20 QUIT
- +21 ;
- GLBBKUP ; XTMP Backup of file(s)
- +1 SET ECXBKUPNDE="ECX*3*191-Update NATIONAL CLINIC FY25 Char4 (#728.441)"
- +2 SET ^XTMP("ECX3P191",0)=$$FMADD^XLFDT(DT,120)_"^"_DT_"^"_ECXBKUPNDE
- +3 MERGE ^XTMP("ECX3P191",ECX191FILE,$HOROLOG)=^ECX(ECX191FILE)
- +4 QUIT
- +5 ;
- ADDCLIN ;Add new code
- +1 ;
- +2 ;
- UPDCLIN ;Contains the NATIONAL CLINIC entry description to be updated
- +1 ;;CDEC^CRH State Veterans Home (for Cleland Dole Pilot)
- +2 ;;HTWC^Welch Allyn BP Machines
- +3 ;;JCBC^Boothless Audiometry Clinic
- +4 ;;MPAL^My Life My Story Program
- +5 ;;WCRC^CRH Provider Type Not Assigned to other Char4
- +6 ;;QUIT