ECX3P159 ;ALB/DE - ECX*3.0*159 Post-Init RTN;09/18/15
;;3.0;DSS EXTRACTS;**159**;Dec 22, 1997;Build 2
;
;Post-init routine adding and updating entries in
;the NATIONAL CLINIC (#728.441) file
;
Q
;
EN ;routine entry point
D ADDNEW ;add new entries
D UPDATE ;change short description of existing clinic codes
D BMES^XPDUTL("Update complete")
;
Q
;
ADDNEW ;Add new entries to file 728.441
;ECXREC is in format: code^short description
;
N ECXFDA,ECXCODE,ECXREC,ECXI,ECXERR
;
D BMES^XPDUTL(">>>Adding entries to the NATIONAL CLINIC (728.441) file..")
;
;-get National Clinic record
F ECXI=1:1 S ECXREC=$P($T(ADDCLIN+ECXI),";;",2) Q:ECXREC="QUIT" D
.;
.;-get National Clinic Code
.S ECXCODE=$P(ECXREC,"^")
.;
.;-quit w/error message if entry already exists in file #728.441
.I $$FIND1^DIC(728.441,"","X",ECXCODE) D Q
..D BMES^XPDUTL(">>>..."_ECXCODE_" "_$P(ECXREC,U,2)_" not added, code already exists.")
..D BMES^XPDUTL("*** Please contact support for assistance. ***")
.;
.;-setup field values of new entry
.S ECXFDA(728.441,"+1,",.01)=ECXCODE
.S ECXFDA(728.441,"+1,",1)=$P(ECXREC,"^",2)
.;
.;-add new entry to file #728.441
.D UPDATE^DIE("E","ECXFDA","","ECXERR")
.;
.I '$D(ECXERR) D BMES^XPDUTL(">>>...."_ECXCODE_" - "_$P(ECXREC,U,2)_" added to file.")
.I $D(ECXERR) D BMES^XPDUTL(">>>....Unable to add "_ECXCODE_" to the file.") D
..D BMES^XPDUTL("*** Please contact support for assistance. ***")
;
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. ***")
.N 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
;
ADDCLIN ;Contains the NATIONAL CLINIC entries to be added
;;LVL6^Mobile Medical Unit 6
;;LVL7^Mobile Medical Unit 7
;;LVL8^Mobile Medical Unit 8
;;LVL9^Mobile Medical Unit 9
;;QUIT
;
UPDCLIN ;Contains the NATIONAL CLINIC entry description to be updated
;;LVL1^Mobile Medical Unit 1
;;LVL2^Mobile Medical Unit 2
;;LVL3^Mobile Medical Unit 3
;;LVL4^Mobile Medical Unit 4
;;LVL5^Mobile Medical Unit 5
;;PNPC^PACT CVT-H Physician
;;PNQC^PACT CVT-H Physician Assistant
;;PNRC^PACT CVT-H Nurse Practitioner
;;PNSC^PACT CVT-H Nurse
;;RDNU^Radiology Oncology Clinic
;;SNRC^VA Provider & Pt at NonVAFacility
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECX3P159 3048 printed Nov 22, 2024@17:00:30 Page 2
ECX3P159 ;ALB/DE - ECX*3.0*159 Post-Init RTN;09/18/15
+1 ;;3.0;DSS EXTRACTS;**159**;Dec 22, 1997;Build 2
+2 ;
+3 ;Post-init routine adding and updating entries in
+4 ;the NATIONAL CLINIC (#728.441) file
+5 ;
+6 QUIT
+7 ;
EN ;routine entry point
+1 ;add new entries
DO ADDNEW
+2 ;change short description of existing clinic codes
DO UPDATE
+3 DO BMES^XPDUTL("Update complete")
+4 ;
+5 QUIT
+6 ;
ADDNEW ;Add new entries to file 728.441
+1 ;ECXREC is in format: code^short description
+2 ;
+3 NEW ECXFDA,ECXCODE,ECXREC,ECXI,ECXERR
+4 ;
+5 DO BMES^XPDUTL(">>>Adding entries to the NATIONAL CLINIC (728.441) file..")
+6 ;
+7 ;-get National Clinic record
+8 FOR ECXI=1:1
SET ECXREC=$PIECE($TEXT(ADDCLIN+ECXI),";;",2)
if ECXREC="QUIT"
QUIT
Begin DoDot:1
+9 ;
+10 ;-get National Clinic Code
+11 SET ECXCODE=$PIECE(ECXREC,"^")
+12 ;
+13 ;-quit w/error message if entry already exists in file #728.441
+14 IF $$FIND1^DIC(728.441,"","X",ECXCODE)
Begin DoDot:2
+15 DO BMES^XPDUTL(">>>..."_ECXCODE_" "_$PIECE(ECXREC,U,2)_" not added, code already exists.")
+16 DO BMES^XPDUTL("*** Please contact support for assistance. ***")
End DoDot:2
QUIT
+17 ;
+18 ;-setup field values of new entry
+19 SET ECXFDA(728.441,"+1,",.01)=ECXCODE
+20 SET ECXFDA(728.441,"+1,",1)=$PIECE(ECXREC,"^",2)
+21 ;
+22 ;-add new entry to file #728.441
+23 DO UPDATE^DIE("E","ECXFDA","","ECXERR")
+24 ;
+25 IF '$DATA(ECXERR)
DO BMES^XPDUTL(">>>...."_ECXCODE_" - "_$PIECE(ECXREC,U,2)_" added to file.")
+26 IF $DATA(ECXERR)
DO BMES^XPDUTL(">>>....Unable to add "_ECXCODE_" to the file.")
Begin DoDot:2
+27 DO BMES^XPDUTL("*** Please contact support for assistance. ***")
End DoDot:2
End DoDot:1
+28 ;
+29 QUIT
+30 ;
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 NEW 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 ;
ADDCLIN ;Contains the NATIONAL CLINIC entries to be added
+1 ;;LVL6^Mobile Medical Unit 6
+2 ;;LVL7^Mobile Medical Unit 7
+3 ;;LVL8^Mobile Medical Unit 8
+4 ;;LVL9^Mobile Medical Unit 9
+5 ;;QUIT
+6 ;
UPDCLIN ;Contains the NATIONAL CLINIC entry description to be updated
+1 ;;LVL1^Mobile Medical Unit 1
+2 ;;LVL2^Mobile Medical Unit 2
+3 ;;LVL3^Mobile Medical Unit 3
+4 ;;LVL4^Mobile Medical Unit 4
+5 ;;LVL5^Mobile Medical Unit 5
+6 ;;PNPC^PACT CVT-H Physician
+7 ;;PNQC^PACT CVT-H Physician Assistant
+8 ;;PNRC^PACT CVT-H Nurse Practitioner
+9 ;;PNSC^PACT CVT-H Nurse
+10 ;;RDNU^Radiology Oncology Clinic
+11 ;;SNRC^VA Provider & Pt at NonVAFacility
+12 ;;QUIT
