ECX147PT ;ALB/AG-ECX*3.0*147 Post-Init Rtn;10/8/13; ; 12/4/13 3:52pm
;;3.0;DSS EXTRACTS;**147**;Dec 22,1997;Build 4
;
;Post-init routine adding new entries and updating current entries to
;
;NATIONAL CLINIC file(#728.441)
;
Q
;
EN ;
;Routine entry point
D UNLOCK ;unlock Data Dictionary to allow changes
D ADDNEW ;add new Clinic codes
D UPDATE ;change name to existing Clinic codes
D LOCK ;lock Data Dictionary to restrict changes
Q
;
UNLOCK ;
K ^DD(728.441,.01,7.5)
N ECXI
F ECXI=.01,1,3 S $P(^DD(728.441,ECXI,0),"^",2)=$TR($P(^DD(728.441,ECXI,0),"^",2),"I","")
Q
ADDNEW ;Add new entry to file 728.441
;ECXREC is in format:code^short description
;
;
N ECXFDA,ECXERR,ECXCODE,ECXREC,ECXI
;
;-get National Clinic record
F ECXI=1:1 S ECXREC=$P($T(ADDCLIN+ECXI),";;",2) Q:ECXREC="QUIT" D
.;
.;-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, entry already exists.")
..D BMES^XPDUTL(">>> 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_" "_$P(ECXREC,U,2)_" to file.") D
..D BMES^XPDUTL(">>>....Contact Support for assistance.")
;
Q
UPDATE ;changing short description of existing clinic
N ECXCODE,ECXDESC,ECXIEN,DIE,DA,DR,ECXI
D BMES^XPDUTL(">>>Updating entry in the NATIONAL CLINIC (728.441) file...")
I $P(^DD(728.441,.01,0),"^",2)["I" D Q
.D BMES^XPDUTL(">>Unable to update File 728.441 is locked")
.D BMES^XPDUTL("Contact support for assistance")
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,"","","ERR")
.I 'ECXIEN D Q
..D BMES^XPDUTL(">>>....Unable to add "_ECXCODE_" "_$P(ECXREC,U,2)_" to file.")
..D BMES^XPDUTL(">>>....Contact support for assistance")
.S DIE="^ECX(728.441,",DA=ECXIEN,DR="1///^S X=ECXDESC"
.D ^DIE
.D BMES^XPDUTL(">>>...."_ECXCODE_" "_$P(ECXREC,U,2)_" updated")
Q
;
LOCK ;
N ECXI
S ^DD(728.441,.01,7.5)="I $G(DIC(0))[""L"",'$D(ECX4CHAR) D EN^DDIOL(""Entries can only be added by CHAR4 Council."","""",""!?5"") K X"
F ECXI=.01,1,3 I $P(^DD(728.441,ECXI,0),U,2)'["I" S $P(^DD(728.441,ECXI,0),U,2)=$P(^DD(728.441,ECXI,0),U,2)_"I" ;Makes all fields uneditable
Q
ADDCLIN ;Contains the NATIONAL CLINIC entries to be added
;;AMSM^Antimicrb Stwrdshp MD
;;PEER^Peer Support
;;APSZ^E-Consult NP or CNS
;;CLSZ^E-Consult PSO or POD
;;PASZ^E-Consult PA
;;RESZ^E-Consult Resident/Fellow
;;VL5Z^E-Consult Contract Labor
;;QUIT
UPDCLIN ;Contains the NATIONAL CLINIC entry description to be updated
;;FEEZ^Profee
;;HDGC^Employment Specialist
;;RHAC^Reserved
;;RHEC^Rehab Audiology
;;RHFC^Rehab Blind Rehab
;;RHGC^Rehab Chiropractic
;;RHHC^Rehab KT
;;RHJC^Rehab MD
;;RHMC^Rehab OT
;;RHRC^Rehab RT
;;RHSC^Rehab SP
;;CNSZ^E-Consult MD/PSI/Gen'l
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECX147PT 3384 printed Apr 09, 2024@20:58:50 Page 2
ECX147PT ;ALB/AG-ECX*3.0*147 Post-Init Rtn;10/8/13; ; 12/4/13 3:52pm
+1 ;;3.0;DSS EXTRACTS;**147**;Dec 22,1997;Build 4
+2 ;
+3 ;Post-init routine adding new entries and updating current entries to
+4 ;
+5 ;NATIONAL CLINIC file(#728.441)
+6 ;
+7 QUIT
+8 ;
EN ;
+1 ;Routine entry point
+2 ;unlock Data Dictionary to allow changes
DO UNLOCK
+3 ;add new Clinic codes
DO ADDNEW
+4 ;change name to existing Clinic codes
DO UPDATE
+5 ;lock Data Dictionary to restrict changes
DO LOCK
+6 QUIT
+7 ;
UNLOCK ;
+1 KILL ^DD(728.441,.01,7.5)
+2 NEW ECXI
+3 FOR ECXI=.01,1,3
SET $PIECE(^DD(728.441,ECXI,0),"^",2)=$TRANSLATE($PIECE(^DD(728.441,ECXI,0),"^",2),"I","")
+4 QUIT
ADDNEW ;Add new entry to file 728.441
+1 ;ECXREC is in format:code^short description
+2 ;
+3 ;
+4 NEW ECXFDA,ECXERR,ECXCODE,ECXREC,ECXI
+5 ;
+6 ;-get National Clinic record
+7 FOR ECXI=1:1
SET ECXREC=$PIECE($TEXT(ADDCLIN+ECXI),";;",2)
if ECXREC="QUIT"
QUIT
Begin DoDot:1
+8 ;
+9 ;-National Clinic Code
+10 SET ECXCODE=$PIECE(ECXREC,"^")
+11 ;
+12 ;-quit w/error message if entry already exists in file #728.441
+13 IF $$FIND1^DIC(728.441,"","X",ECXCODE)
Begin DoDot:2
+14 DO BMES^XPDUTL(">>>..."_ECXCODE_" "_$PIECE(ECXREC,U,2)_" not added, entry already exists.")
+15 DO BMES^XPDUTL(">>> Contact Support for assistance.")
End DoDot:2
QUIT
+16 ;
+17 ;Setup field values of new entry
+18 SET ECXFDA(728.441,"+1,",.01)=ECXCODE
+19 SET ECXFDA(728.441,"+1,",1)=$PIECE(ECXREC,"^",2)
+20 ;
+21 ;-add new entry to file #728.441
+22 DO UPDATE^DIE("E","ECXFDA","","ECXERR")
+23 ;
+24 IF '$DATA(ECXERR)
DO BMES^XPDUTL(">>>...."_ECXCODE_" "_$PIECE(ECXREC,U,2)_" added to file.")
+25 IF $DATA(ECXERR)
DO BMES^XPDUTL(">>>....Unable to add "_ECXCODE_" "_$PIECE(ECXREC,U,2)_" to file.")
Begin DoDot:2
+26 DO BMES^XPDUTL(">>>....Contact Support for assistance.")
End DoDot:2
End DoDot:1
+27 ;
+28 QUIT
UPDATE ;changing short description of existing clinic
+1 NEW ECXCODE,ECXDESC,ECXIEN,DIE,DA,DR,ECXI
+2 DO BMES^XPDUTL(">>>Updating entry in the NATIONAL CLINIC (728.441) file...")
+3 IF $PIECE(^DD(728.441,.01,0),"^",2)["I"
Begin DoDot:1
+4 DO BMES^XPDUTL(">>Unable to update File 728.441 is locked")
+5 DO BMES^XPDUTL("Contact support for assistance")
End DoDot:1
QUIT
+6 FOR ECXI=1:1
SET ECXREC=$PIECE($TEXT(UPDCLIN+ECXI),";;",2)
if ECXREC="QUIT"
QUIT
Begin DoDot:1
+7 SET ECXCODE=$PIECE(ECXREC,"^")
SET ECXDESC=$PIECE(ECXREC,"^",2)
+8 SET ECXIEN=$$FIND1^DIC(728.441,"","X",ECXCODE,"","","ERR")
+9 IF 'ECXIEN
Begin DoDot:2
+10 DO BMES^XPDUTL(">>>....Unable to add "_ECXCODE_" "_$PIECE(ECXREC,U,2)_" to file.")
+11 DO BMES^XPDUTL(">>>....Contact support for assistance")
End DoDot:2
QUIT
+12 SET DIE="^ECX(728.441,"
SET DA=ECXIEN
SET DR="1///^S X=ECXDESC"
+13 DO ^DIE
+14 DO BMES^XPDUTL(">>>...."_ECXCODE_" "_$PIECE(ECXREC,U,2)_" updated")
End DoDot:1
+15 QUIT
+16 ;
LOCK ;
+1 NEW ECXI
+2 SET ^DD(728.441,.01,7.5)="I $G(DIC(0))[""L"",'$D(ECX4CHAR) D EN^DDIOL(""Entries can only be added by CHAR4 Council."","""",""!?5"") K X"
+3 ;Makes all fields uneditable
FOR ECXI=.01,1,3
IF $PIECE(^DD(728.441,ECXI,0),U,2)'["I"
SET $PIECE(^DD(728.441,ECXI,0),U,2)=$PIECE(^DD(728.441,ECXI,0),U,2)_"I"
+4 QUIT
ADDCLIN ;Contains the NATIONAL CLINIC entries to be added
+1 ;;AMSM^Antimicrb Stwrdshp MD
+2 ;;PEER^Peer Support
+3 ;;APSZ^E-Consult NP or CNS
+4 ;;CLSZ^E-Consult PSO or POD
+5 ;;PASZ^E-Consult PA
+6 ;;RESZ^E-Consult Resident/Fellow
+7 ;;VL5Z^E-Consult Contract Labor
+8 ;;QUIT
UPDCLIN ;Contains the NATIONAL CLINIC entry description to be updated
+1 ;;FEEZ^Profee
+2 ;;HDGC^Employment Specialist
+3 ;;RHAC^Reserved
+4 ;;RHEC^Rehab Audiology
+5 ;;RHFC^Rehab Blind Rehab
+6 ;;RHGC^Rehab Chiropractic
+7 ;;RHHC^Rehab KT
+8 ;;RHJC^Rehab MD
+9 ;;RHMC^Rehab OT
+10 ;;RHRC^Rehab RT
+11 ;;RHSC^Rehab SP
+12 ;;CNSZ^E-Consult MD/PSI/Gen'l
+13 ;;QUIT
