ECDSS ;BIR/RHK,JPW-Enter/Edit Local Procedures ;30 Apr 96
;;2.0; EVENT CAPTURE ;**4,23,30**;8 May 96
NEWED ;
W @IOF,!,"Enter/Edit Local Procedures",!
K DIR S DIR(0)="YO",DIR("A")="Would you like to review a listing of your current local procedures",DIR("B")="NO"
S DIR("?")="Answer YES to print a listing of your current local procedures, answer or <RET> to continue without the listing, or ^ to exit."
D ^DIR K DIR I $D(DIRUT) D MSG G END
I Y D LIST
ASK ;ask for procedure name
K LN S $P(LN,"*",65)="" W !!,?5,LN
W !,?5,"* You must enter an associated CPT with your local procedure",?68,"*",!,?5,"* to pass this procedural data to PCE.",?68,"*",!,?5,LN,! K LN
W ! K DIR,DIRUT,ECRN,ECPN,ECNA S DIR(0)="FO^3:50^K:X'?1AN.ANLP X"
S DIR("A")="Enter Local Procedure"
S DIR("?")="Enter a free text name from 3 to 50 characters" D ^DIR K DIR I Y="" G END
I $D(DIRUT) D MSG G END
W !!,"Checking current procedures...",! S ECPN=Y
S ECOUT=0,(ECP,ECPR)="" F S ECP=$O(^EC(725,"B",ECP)) Q:(ECP="")!(ECOUT)!(ECPR) I ECP[ECPN D QUEST Q:(ECOUT)!(ECPR)
G:ECOUT END
I ECPR S ECJLP=0 D EDIT G ASK
W ! K DIR,DIRUT,DTOUT,DUOUT S DIR(0)="YO",DIR("A")="Are you sure you want to add "_ECPN_" as a new local procedure",DIR("B")="YES"
S DIR("?")="Answer YES or <RET> to add the procedure locally, NO to enter a different procedure name, or ^ to exit"
D ^DIR K DIR I $D(DIRUT) D MSG G END
I 'Y S ECJLP=0 D MSG2 G ASK
NUM ; set proc # code
W !!,"Local Procedure: ",ECPN,!
W !,?5,"** Please NOTE: The number code must be 5 characters in length,",!,?23,"starting with an uppercase alpha character,",!,?23,"followed by 4 alpha or numeric characters.",!
S DIR(0)="F^5:5^K:X'?1U.4AN X",DIR("A")="Enter Local Procedure Code Number",DIR("?")="Enter your locally defined national number for this procedure"
N UPY D ^DIR K DIR I $D(DIRUT) S ECJLP=1 D MSG2 G ASK
S UPY=$$UP^XLFSTR(Y)
I $D(^EC(725,"E",Y))!($D(^EC(725,"E",UPY))) D MSG1 K Y G NUM
I $D(^EC(725,"D",Y))!($D(^EC(725,"D",UPY))) D MSG1 K Y G NUM
I $D(^EC(725,"DL",Y))!($D(^EC(725,"DL",UPY))) D MSG1 K Y G NUM
S ECNA=Y
FIND ;find next number
L +^EC(725):1
S ECRN=$O(^EC(725," "),-1)
F S ECRN=ECRN+1 Q:'$D(^EC(725,ECRN))
I ECRN<90001 S ECRN=90001
S $P(^EC(725,0),"^",3)=ECRN,$P(^EC(725,0),"^",4)=$P(^EC(725,0),"^",4)+1
L -^EC(725)
S ^EC(725,ECRN,0)=ECPN_"^"_ECNA
INDEX ; Set file indexes
S DIK="^EC(725,",DA=ECRN,DIK(1)=".01" D EN^DIK K DIK
S DIK="^EC(725,",DA=ECRN,DIK(1)="1" D EN^DIK K DIK
S DIE=725,DR="4" D ^DIE K DA,DIE
W !,ECPN," added.",! G ASK
END ;kill variables
D ^ECKILL
Q
LIST ;List of local procedures
S ECNR=90000,(ECJLP,ECOUT)=0
D HDRL Q:ECOUT
F S ECNR=$O(^EC(725,ECNR)) Q:'ECNR!(ECOUT) I $D(^EC(725,ECNR,0)) S ECJLP=ECJLP+1 D:$Y+5>IOSL HDRL W !,$P(^(0),"^"),?45,$P(^(0),"^",2),!
W:'ECJLP !,?5,"**** No Local Procedures Defined ****",!
Q
HDRL ;hdr for listing
I $Y+5>IOSL K DIR,DIRUT S DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S ECOUT=1 Q
Q:ECOUT
W @IOF,!,"Listing local procedures...",!!,"Procedure Name",?40,"National #/Code",!
Q
EDIT ;
I ECPR<90000 W !,ECPN," is a nationally defined procedure.",!,"You cannot edit this procedure.",! S ECJLP=1 D MSG Q
K DA,DIR,DIRUT S DA=+ECPR,EC1=$P($G(^EC(725,+ECPR,0)),"^"),DIR(0)="FO^3:50^K:X'?1AN.ANLP X",DIR("B")=EC1
S DIR("A")="Edit Local Procedure",DIR("?")="Edit the existing procedure name or press <RET> to quit without editing the name"
D ^DIR K DIR I $D(DIRUT) D MSG Q
I Y="" G DIE
I Y]"",Y'=EC1 S ECNEW=Y D SURE
DIE ;edit nat #
K DA,DIE S DIE=725,DA=ECPR,DR="1;4" D ^DIE K DA,DIR,DR
Q
SURE ;ask edit
W !!,"You want to change the procedure name ",EC1,!,"to ",Y,"."
K DA,DIR S DIR(0)="YO",DIR("A")="Are you sure ",DIR("?")="Answer YES to replace the procedure name, NO or ^ to quit"
D ^DIR I $D(DIRUT) D MSG S ECOUT=1 Q
I 'Y D MSG Q
I Y S $P(^EC(725,+ECPR,0),"^")=ECNEW K ^EC(725,"B",EC1,ECPR) K DA,DIK S DA=+ECPR,DIK="^EC(725,",DIK(1)=".01" D EN^DIK K DA,DIK W !!,"Named has been changed to ",ECNEW,".",!!
Q
MSG ;message
W !,"No action taken.",!
Q
MSG1 ;dup number msg
W !,Y," currently exists. The must be a unique number code.",!,"Enter a different code for this local procedure.",!
Q
MSG2 ;
W !,"Procedure ",ECPN," was not added."
W:ECJLP !,"A unique number code was not entered." W !
Q
QUEST ;ask if match
K DIR,DIRUT,DTOUT,DUOUT S DIR(0)="YO",DIR("A")="Do you want to edit "_ECP_" procedure",DIR("B")="YES"
S DIR("?")="Answer YES to edit this procedure, NO to continue, or ^ to exit"
D ^DIR K DIR I $D(DIRUT) D MSG S ECOUT=1 Q
I Y S ECPR="",ECPR=$O(^EC(725,"B",ECP,ECPR))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECDSS 4640 printed Oct 16, 2024@17:57:52 Page 2
ECDSS ;BIR/RHK,JPW-Enter/Edit Local Procedures ;30 Apr 96
+1 ;;2.0; EVENT CAPTURE ;**4,23,30**;8 May 96
NEWED ;
+1 WRITE @IOF,!,"Enter/Edit Local Procedures",!
+2 KILL DIR
SET DIR(0)="YO"
SET DIR("A")="Would you like to review a listing of your current local procedures"
SET DIR("B")="NO"
+3 SET DIR("?")="Answer YES to print a listing of your current local procedures, answer or <RET> to continue without the listing, or ^ to exit."
+4 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO MSG
GOTO END
+5 IF Y
DO LIST
ASK ;ask for procedure name
+1 KILL LN
SET $PIECE(LN,"*",65)=""
WRITE !!,?5,LN
+2 WRITE !,?5,"* You must enter an associated CPT with your local procedure",?68,"*",!,?5,"* to pass this procedural data to PCE.",?68,"*",!,?5,LN,!
KILL LN
+3 WRITE !
KILL DIR,DIRUT,ECRN,ECPN,ECNA
SET DIR(0)="FO^3:50^K:X'?1AN.ANLP X"
+4 SET DIR("A")="Enter Local Procedure"
+5 SET DIR("?")="Enter a free text name from 3 to 50 characters"
DO ^DIR
KILL DIR
IF Y=""
GOTO END
+6 IF $DATA(DIRUT)
DO MSG
GOTO END
+7 WRITE !!,"Checking current procedures...",!
SET ECPN=Y
+8 SET ECOUT=0
SET (ECP,ECPR)=""
FOR
SET ECP=$ORDER(^EC(725,"B",ECP))
if (ECP="")!(ECOUT)!(ECPR)
QUIT
IF ECP[ECPN
DO QUEST
if (ECOUT)!(ECPR)
QUIT
+9 if ECOUT
GOTO END
+10 IF ECPR
SET ECJLP=0
DO EDIT
GOTO ASK
+11 WRITE !
KILL DIR,DIRUT,DTOUT,DUOUT
SET DIR(0)="YO"
SET DIR("A")="Are you sure you want to add "_ECPN_" as a new local procedure"
SET DIR("B")="YES"
+12 SET DIR("?")="Answer YES or <RET> to add the procedure locally, NO to enter a different procedure name, or ^ to exit"
+13 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO MSG
GOTO END
+14 IF 'Y
SET ECJLP=0
DO MSG2
GOTO ASK
NUM ; set proc # code
+1 WRITE !!,"Local Procedure: ",ECPN,!
+2 WRITE !,?5,"** Please NOTE: The number code must be 5 characters in length,",!,?23,"starting with an uppercase alpha character,",!,?23,"followed by 4 alpha or numeric characters.",!
+3 SET DIR(0)="F^5:5^K:X'?1U.4AN X"
SET DIR("A")="Enter Local Procedure Code Number"
SET DIR("?")="Enter your locally defined national number for this procedure"
+4 NEW UPY
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET ECJLP=1
DO MSG2
GOTO ASK
+5 SET UPY=$$UP^XLFSTR(Y)
+6 IF $DATA(^EC(725,"E",Y))!($DATA(^EC(725,"E",UPY)))
DO MSG1
KILL Y
GOTO NUM
+7 IF $DATA(^EC(725,"D",Y))!($DATA(^EC(725,"D",UPY)))
DO MSG1
KILL Y
GOTO NUM
+8 IF $DATA(^EC(725,"DL",Y))!($DATA(^EC(725,"DL",UPY)))
DO MSG1
KILL Y
GOTO NUM
+9 SET ECNA=Y
FIND ;find next number
+1 LOCK +^EC(725):1
+2 SET ECRN=$ORDER(^EC(725," "),-1)
+3 FOR
SET ECRN=ECRN+1
if '$DATA(^EC(725,ECRN))
QUIT
+4 IF ECRN<90001
SET ECRN=90001
+5 SET $PIECE(^EC(725,0),"^",3)=ECRN
SET $PIECE(^EC(725,0),"^",4)=$PIECE(^EC(725,0),"^",4)+1
+6 LOCK -^EC(725)
+7 SET ^EC(725,ECRN,0)=ECPN_"^"_ECNA
INDEX ; Set file indexes
+1 SET DIK="^EC(725,"
SET DA=ECRN
SET DIK(1)=".01"
DO EN^DIK
KILL DIK
+2 SET DIK="^EC(725,"
SET DA=ECRN
SET DIK(1)="1"
DO EN^DIK
KILL DIK
+3 SET DIE=725
SET DR="4"
DO ^DIE
KILL DA,DIE
+4 WRITE !,ECPN," added.",!
GOTO ASK
END ;kill variables
+1 DO ^ECKILL
+2 QUIT
LIST ;List of local procedures
+1 SET ECNR=90000
SET (ECJLP,ECOUT)=0
+2 DO HDRL
if ECOUT
QUIT
+3 FOR
SET ECNR=$ORDER(^EC(725,ECNR))
if 'ECNR!(ECOUT)
QUIT
IF $DATA(^EC(725,ECNR,0))
SET ECJLP=ECJLP+1
if $Y+5>IOSL
DO HDRL
WRITE !,$PIECE(^(0),"^"),?45,$PIECE(^(0),"^",2),!
+4 if 'ECJLP
WRITE !,?5,"**** No Local Procedures Defined ****",!
+5 QUIT
HDRL ;hdr for listing
+1 IF $Y+5>IOSL
KILL DIR,DIRUT
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET ECOUT=1
QUIT
+2 if ECOUT
QUIT
+3 WRITE @IOF,!,"Listing local procedures...",!!,"Procedure Name",?40,"National #/Code",!
+4 QUIT
EDIT ;
+1 IF ECPR<90000
WRITE !,ECPN," is a nationally defined procedure.",!,"You cannot edit this procedure.",!
SET ECJLP=1
DO MSG
QUIT
+2 KILL DA,DIR,DIRUT
SET DA=+ECPR
SET EC1=$PIECE($GET(^EC(725,+ECPR,0)),"^")
SET DIR(0)="FO^3:50^K:X'?1AN.ANLP X"
SET DIR("B")=EC1
+3 SET DIR("A")="Edit Local Procedure"
SET DIR("?")="Edit the existing procedure name or press <RET> to quit without editing the name"
+4 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO MSG
QUIT
+5 IF Y=""
GOTO DIE
+6 IF Y]""
IF Y'=EC1
SET ECNEW=Y
DO SURE
DIE ;edit nat #
+1 KILL DA,DIE
SET DIE=725
SET DA=ECPR
SET DR="1;4"
DO ^DIE
KILL DA,DIR,DR
+2 QUIT
SURE ;ask edit
+1 WRITE !!,"You want to change the procedure name ",EC1,!,"to ",Y,"."
+2 KILL DA,DIR
SET DIR(0)="YO"
SET DIR("A")="Are you sure "
SET DIR("?")="Answer YES to replace the procedure name, NO or ^ to quit"
+3 DO ^DIR
IF $DATA(DIRUT)
DO MSG
SET ECOUT=1
QUIT
+4 IF 'Y
DO MSG
QUIT
+5 IF Y
SET $PIECE(^EC(725,+ECPR,0),"^")=ECNEW
KILL ^EC(725,"B",EC1,ECPR)
KILL DA,DIK
SET DA=+ECPR
SET DIK="^EC(725,"
SET DIK(1)=".01"
DO EN^DIK
KILL DA,DIK
WRITE !!,"Named has been changed to ",ECNEW,".",!!
+6 QUIT
MSG ;message
+1 WRITE !,"No action taken.",!
+2 QUIT
MSG1 ;dup number msg
+1 WRITE !,Y," currently exists. The must be a unique number code.",!,"Enter a different code for this local procedure.",!
+2 QUIT
MSG2 ;
+1 WRITE !,"Procedure ",ECPN," was not added."
+2 if ECJLP
WRITE !,"A unique number code was not entered."
WRITE !
+3 QUIT
QUEST ;ask if match
+1 KILL DIR,DIRUT,DTOUT,DUOUT
SET DIR(0)="YO"
SET DIR("A")="Do you want to edit "_ECP_" procedure"
SET DIR("B")="YES"
+2 SET DIR("?")="Answer YES to edit this procedure, NO to continue, or ^ to exit"
+3 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO MSG
SET ECOUT=1
QUIT
+4 IF Y
SET ECPR=""
SET ECPR=$ORDER(^EC(725,"B",ECP,ECPR))
+5 QUIT
