EC2P125.m

EC2P125 ;ALB/DE - EC National Procedure (#725) Update ; 10/4/12 11:00am

 ;;2.0;EVENT CAPTURE;**125**;8 May 96;Build 1

 ;

 ;this routine is used as a post-init in a KIDS build

 ;to modify the EC National Procedure (#725) file

 ;

 Q

 ;

POST ;* entry point

 N ECVRRV

 ;* if 725 already updated, write message

 ;  since check inserted in addproc subroutine, patch may be re-installed

 I $$GET1^DID(725,"","","PACKAGE REVISION DATA")["EC*2*125" D

 .D MES^XPDUTL(" ")

 .D MES^XPDUTL("It appears that the EC NATIONAL PROCEDURE")

 .D MES^XPDUTL("(#725) file has already been updated")

 .D MES^XPDUTL("with Patch EC*2*125.")

 .D MES^XPDUTL(" ")

 .D MES^XPDUTL("But the patch may be re-installed...")

 .D MES^XPDUTL(" ")

 D UPDATE

 Q

 ;

UPDATE ;* update the file

 D MES^XPDUTL(" ")

 D BMES^XPDUTL("Updating the EC NATIONAL PROCEDURE (#725) file...")

 D MES^XPDUTL(" ")

 ;

 ;* add new/edit national procedures

 D ADDPROC ;add new procedures

 D NAMECHG ;change description

 ;

 S ECVRRV=$$GET1^DID(725,"","","PACKAGE REVISION DATA")

 S ECVRRV=ECVRRV_"^EC*2*125"

 D PRD^DILFD(725,ECVRRV)

 D MES^XPDUTL(" ")

 D BMES^XPDUTL("Update of EC NATIONAL PROCEDURE (#725) file")

 D BMES^XPDUTL("   completed...")

 D MES^XPDUTL(" ")

 Q

 ;

ADDPROC ;* add national procedures

 ;

 ;  ECXX is in format:

 ;   NAME^NATIONAL NUMBER^CPT CODE^FIRST NATIONAL NUMBER SEQUENCE

 ;   LAST NATIONAL NUMBER SEQUENCE

 ;

 N ECX,ECXX,ECDINUM,ECNAME,ECCODE,ECCPT,ECCOUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM

 N ECADD,ECBEG,ECEND,ECCODX,ECNAMX,ECSEQ,ECLIEN,ECSTR,ECCPTN

 D MES^XPDUTL(" ")

 D BMES^XPDUTL("Adding new procedures to EC NATIONAL PROCEDURE (#725) file...")

 D MES^XPDUTL(" ")

 S ECDINUM=$O(^EC(725,9999),-1),ECCOUNT=$P(^EC(725,0),U,4)

 F ECX=1:1 S ECXX=$P($T(NEW+ECX),";;",2) Q:ECXX="QUIT"  D

 .S ECNAME=$P(ECXX,U,1),ECCODE=$P(ECXX,U,2),ECCPTN=$P(ECXX,U,3),ECCODX=ECCODE

 .S ECCPT=""

 .I ECCPTN'="" S ECCPT=$$FIND1^DIC(81,"","X",ECCPTN) I +ECCPT<1 D  Q

 ..S ECSTR="   CPT code "_ECCPTN_" not a valid code in CPT File."

 ..D MES^XPDUTL(" ")

 ..D BMES^XPDUTL("   ["_ECCODE_"] "_ECSTR)

 .S ECBEG=$P(ECXX,U,4),ECEND=$P(ECXX,U,5),ECNAMX=ECNAME

 .I ECBEG="" S X=ECNAME D FILPROC Q

 .F ECSEQ=ECBEG:1:ECEND D

 ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))

 ..I $E(ECCODX,1,3)'="RCM" S ECNAME=ECNAMX_ECSEQ,X=ECNAME,ECCODE=ECCODX_ECADD

 ..E  S ECNAME=ECNAMX_$E(ECADD,2,99),X=ECNAME,ECCODE=ECCODX_$E(ECADD,2,99)

 ..D FILPROC

 S $P(^EC(725,0),U,4)=ECCOUNT,X=$O(^EC(725,999999),-1),$P(^EC(725,0),U,3)=X

 Q

 ;

FILPROC ;* File national procedures

 I '$D(^EC(725,"D",ECCODE)) D

 .S ECDINUM=ECDINUM+1,DINUM=ECDINUM,DIC(0)="L",DLAYGO=725,DIC="^EC(725,"

 .S DIC("DR")="1////^S X=ECCODE;4///^S X=ECCPT"

 .D FILE^DICN

 .I +Y>0 D

 ..S ECCOUNT=ECCOUNT+1

 ..D MES^XPDUTL(" ")

 ..S ECSTR="   Entry #"_+Y_" for "_$P(Y,U,2)

 ..S ECSTR=ECSTR_$S(ECCPT'="":" [CPT: "_ECCPT_"]",1:"")_" ("_ECCODE_")"

 ..D BMES^XPDUTL(ECSTR_"  ...successfully added.")

 .I Y=-1 D

 ..D MES^XPDUTL(" ")

 ..D BMES^XPDUTL("ERROR when attempting to add "_ECNAME_" ("_ECCODE_")")

 I $D(^EC(725,"DL",ECCODE)) D

 .S ECLIEN=$O(^EC(725,"DL",ECCODE,""))

 .D MES^XPDUTL(" ")

 .D BMES^XPDUTL("   Your site has a local procedure (entry #"_ECLIEN_") in File #725")

 .D BMES^XPDUTL("   which uses "_ECCODE_" as its National Number.")

 .D BMES^XPDUTL("   Please inactivate this local procedure.")

 .K Y

 Q

 ;

NEW ;* national procedures to add -procedure name^national #^CPT code^beg seq^end seq

 ;;GROUP IPT^CH125^

 ;;STATUS MALNUTRITION^NU215^

 ;;QUIT

 ;

NAMECHG ;* change national procedure names

 ;

 ;  ECXX is in format:

 ;   NATIONAL NUMBER^NEW NAME

 ;

 N ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y,ECSTR

 D MES^XPDUTL(" ")

 D BMES^XPDUTL("Changing names in EC NATIONAL PROCEDURE (#725) file...")

 D MES^XPDUTL(" ")

 F ECX=1:1 S ECXX=$P($T(CHNG+ECX),";;",2) Q:ECXX="QUIT"  D

 .I $D(^EC(725,"D",$P(ECXX,U,1))) D

 ..S ECDA=+$O(^EC(725,"D",$P(ECXX,U,1),0))

 ..I $D(^EC(725,ECDA,0)) D

 ...S DA=ECDA,DR=".01////^S X=$P(ECXX,U,2)",DIE="^EC(725," D ^DIE

 ...D MES^XPDUTL(" ")

 ...D MES^XPDUTL("   Entry #"_ECDA_" for "_$P(ECXX,U,1))

 ...D BMES^XPDUTL("      ... field (#.01) updated to  "_$P(ECXX,U,2)_".")

 .I '$D(^EC(725,"D",$P(ECXX,U,1))) D

 ..D MES^XPDUTL(" ")

 ..S ECSTR="Can't find entry for "_$P(ECXX,U,1)

 ..D BMES^XPDUTL(ECSTR_" ...field (#.01) not updated.")

 Q

 ;

CHNG ;* name changes -national #^new procedure name

 ;;NU151^NUTR CNSLG IND EA A'L 15M

 ;;SW136^CONSULT F2F ONLY, 15M 

 ;;QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---EC2P125   4523     printed  Feb 18, 2025@23:21:12                                                                                                                                                                                                     Page 2

EC2P125   ;ALB/DE - EC National Procedure (#725) Update ; 10/4/12 11:00am

 +1       ;;2.0;EVENT CAPTURE;**125**;8 May 96;Build 1

 +2       ;

 +3       ;this routine is used as a post-init in a KIDS build

 +4       ;to modify the EC National Procedure (#725) file

 +5       ;

 +6        QUIT 

 +7       ;

POST      ;* entry point

 +1        NEW ECVRRV

 +2       ;* if 725 already updated, write message

 +3       ;  since check inserted in addproc subroutine, patch may be re-installed

 +4        IF $$GET1^DID(725,"","","PACKAGE REVISION DATA")["EC*2*125"

               Begin DoDot:1

 +5                DO MES^XPDUTL(" ")

 +6                DO MES^XPDUTL("It appears that the EC NATIONAL PROCEDURE")

 +7                DO MES^XPDUTL("(#725) file has already been updated")

 +8                DO MES^XPDUTL("with Patch EC*2*125.")

 +9                DO MES^XPDUTL(" ")

 +10               DO MES^XPDUTL("But the patch may be re-installed...")

 +11               DO MES^XPDUTL(" ")

               End DoDot:1

 +12       DO UPDATE

 +13       QUIT 

 +14      ;

UPDATE    ;* update the file

 +1        DO MES^XPDUTL(" ")

 +2        DO BMES^XPDUTL("Updating the EC NATIONAL PROCEDURE (#725) file...")

 +3        DO MES^XPDUTL(" ")

 +4       ;

 +5       ;* add new/edit national procedures

 +6       ;add new procedures

           DO ADDPROC

 +7       ;change description

           DO NAMECHG

 +8       ;

 +9        SET ECVRRV=$$GET1^DID(725,"","","PACKAGE REVISION DATA")

 +10       SET ECVRRV=ECVRRV_"^EC*2*125"

 +11       DO PRD^DILFD(725,ECVRRV)

 +12       DO MES^XPDUTL(" ")

 +13       DO BMES^XPDUTL("Update of EC NATIONAL PROCEDURE (#725) file")

 +14       DO BMES^XPDUTL("   completed...")

 +15       DO MES^XPDUTL(" ")

 +16       QUIT 

 +17      ;

ADDPROC   ;* add national procedures

 +1       ;

 +2       ;  ECXX is in format:

 +3       ;   NAME^NATIONAL NUMBER^CPT CODE^FIRST NATIONAL NUMBER SEQUENCE

 +4       ;   LAST NATIONAL NUMBER SEQUENCE

 +5       ;

 +6        NEW ECX,ECXX,ECDINUM,ECNAME,ECCODE,ECCPT,ECCOUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM

 +7        NEW ECADD,ECBEG,ECEND,ECCODX,ECNAMX,ECSEQ,ECLIEN,ECSTR,ECCPTN

 +8        DO MES^XPDUTL(" ")

 +9        DO BMES^XPDUTL("Adding new procedures to EC NATIONAL PROCEDURE (#725) file...")

 +10       DO MES^XPDUTL(" ")

 +11       SET ECDINUM=$ORDER(^EC(725,9999),-1)

           SET ECCOUNT=$PIECE(^EC(725,0),U,4)

 +12       FOR ECX=1:1

               SET ECXX=$PIECE($TEXT(NEW+ECX),";;",2)

               if ECXX="QUIT"

                   QUIT 

               Begin DoDot:1

 +13               SET ECNAME=$PIECE(ECXX,U,1)

                   SET ECCODE=$PIECE(ECXX,U,2)

                   SET ECCPTN=$PIECE(ECXX,U,3)

                   SET ECCODX=ECCODE

 +14               SET ECCPT=""

 +15               IF ECCPTN'=""

                       SET ECCPT=$$FIND1^DIC(81,"","X",ECCPTN)

                       IF +ECCPT<1

                           Begin DoDot:2

 +16                           SET ECSTR="   CPT code "_ECCPTN_" not a valid code in CPT File."

 +17                           DO MES^XPDUTL(" ")

 +18                           DO BMES^XPDUTL("   ["_ECCODE_"] "_ECSTR)

                           End DoDot:2

                           QUIT 

 +19               SET ECBEG=$PIECE(ECXX,U,4)

                   SET ECEND=$PIECE(ECXX,U,5)

                   SET ECNAMX=ECNAME

 +20               IF ECBEG=""

                       SET X=ECNAME

                       DO FILPROC

                       QUIT 

 +21               FOR ECSEQ=ECBEG:1:ECEND

                       Begin DoDot:2

 +22                       SET ECADD="000"_ECSEQ

                           SET ECADD=$EXTRACT(ECADD,$LENGTH(ECADD)-2,$LENGTH(ECADD))

 +23                       IF $EXTRACT(ECCODX,1,3)'="RCM"

                               SET ECNAME=ECNAMX_ECSEQ

                               SET X=ECNAME

                               SET ECCODE=ECCODX_ECADD

 +24                      IF '$TEST

                               SET ECNAME=ECNAMX_$EXTRACT(ECADD,2,99)

                               SET X=ECNAME

                               SET ECCODE=ECCODX_$EXTRACT(ECADD,2,99)

 +25                       DO FILPROC

                       End DoDot:2

               End DoDot:1

 +26       SET $PIECE(^EC(725,0),U,4)=ECCOUNT

           SET X=$ORDER(^EC(725,999999),-1)

           SET $PIECE(^EC(725,0),U,3)=X

 +27       QUIT 

 +28      ;

FILPROC   ;* File national procedures

 +1        IF '$DATA(^EC(725,"D",ECCODE))

               Begin DoDot:1

 +2                SET ECDINUM=ECDINUM+1

                   SET DINUM=ECDINUM

                   SET DIC(0)="L"

                   SET DLAYGO=725

                   SET DIC="^EC(725,"

 +3                SET DIC("DR")="1////^S X=ECCODE;4///^S X=ECCPT"

 +4                DO FILE^DICN

 +5                IF +Y>0

                       Begin DoDot:2

 +6                        SET ECCOUNT=ECCOUNT+1

 +7                        DO MES^XPDUTL(" ")

 +8                        SET ECSTR="   Entry #"_+Y_" for "_$PIECE(Y,U,2)

 +9                        SET ECSTR=ECSTR_$SELECT(ECCPT'="":" [CPT: "_ECCPT_"]",1:"")_" ("_ECCODE_")"

 +10                       DO BMES^XPDUTL(ECSTR_"  ...successfully added.")

                       End DoDot:2

 +11               IF Y=-1

                       Begin DoDot:2

 +12                       DO MES^XPDUTL(" ")

 +13                       DO BMES^XPDUTL("ERROR when attempting to add "_ECNAME_" ("_ECCODE_")")

                       End DoDot:2

               End DoDot:1

 +14       IF $DATA(^EC(725,"DL",ECCODE))

               Begin DoDot:1

 +15               SET ECLIEN=$ORDER(^EC(725,"DL",ECCODE,""))

 +16               DO MES^XPDUTL(" ")

 +17               DO BMES^XPDUTL("   Your site has a local procedure (entry #"_ECLIEN_") in File #725")

 +18               DO BMES^XPDUTL("   which uses "_ECCODE_" as its National Number.")

 +19               DO BMES^XPDUTL("   Please inactivate this local procedure.")

 +20               KILL Y

               End DoDot:1

 +21       QUIT 

 +22      ;

NEW       ;* national procedures to add -procedure name^national #^CPT code^beg seq^end seq

 +1       ;;GROUP IPT^CH125^

 +2       ;;STATUS MALNUTRITION^NU215^

 +3       ;;QUIT

 +4       ;

NAMECHG   ;* change national procedure names

 +1       ;

 +2       ;  ECXX is in format:

 +3       ;   NATIONAL NUMBER^NEW NAME

 +4       ;

 +5        NEW ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y,ECSTR

 +6        DO MES^XPDUTL(" ")

 +7        DO BMES^XPDUTL("Changing names in EC NATIONAL PROCEDURE (#725) file...")

 +8        DO MES^XPDUTL(" ")

 +9        FOR ECX=1:1

               SET ECXX=$PIECE($TEXT(CHNG+ECX),";;",2)

               if ECXX="QUIT"

                   QUIT 

               Begin DoDot:1

 +10               IF $DATA(^EC(725,"D",$PIECE(ECXX,U,1)))

                       Begin DoDot:2

 +11                       SET ECDA=+$ORDER(^EC(725,"D",$PIECE(ECXX,U,1),0))

 +12                       IF $DATA(^EC(725,ECDA,0))

                               Begin DoDot:3

 +13                               SET DA=ECDA

                                   SET DR=".01////^S X=$P(ECXX,U,2)"

                                   SET DIE="^EC(725,"

                                   DO ^DIE

 +14                               DO MES^XPDUTL(" ")

 +15                               DO MES^XPDUTL("   Entry #"_ECDA_" for "_$PIECE(ECXX,U,1))

 +16                               DO BMES^XPDUTL("      ... field (#.01) updated to  "_$PIECE(ECXX,U,2)_".")

                               End DoDot:3

                       End DoDot:2

 +17               IF '$DATA(^EC(725,"D",$PIECE(ECXX,U,1)))

                       Begin DoDot:2

 +18                       DO MES^XPDUTL(" ")

 +19                       SET ECSTR="Can't find entry for "_$PIECE(ECXX,U,1)

 +20                       DO BMES^XPDUTL(ECSTR_" ...field (#.01) not updated.")

                       End DoDot:2

               End DoDot:1

 +21       QUIT 

 +22      ;

CHNG      ;* name changes -national #^new procedure name

 +1       ;;NU151^NUTR CNSLG IND EA A'L 15M

 +2       ;;SW136^CONSULT F2F ONLY, 15M 

 +3       ;;QUIT