| [613] | 1 | DG53757P ;ALB/MRY - Add/Rename SURGICAL SPECIALTIES ; 6/4/07 11:05am
|
|---|
| 2 | ;;5.3;Registration;**757**;Aug 13, 1993;Build 5
|
|---|
| 3 | ;
|
|---|
| 4 | EN ;
|
|---|
| 5 | S XPDABORT=""
|
|---|
| 6 | I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D G ABRT
|
|---|
| 7 | . D BMES^XPDUTL("*****")
|
|---|
| 8 | . D MES^XPDUTL("Your Programming variables are not set up properly.")
|
|---|
| 9 | . D MES^XPDUTL("Installation aborted.")
|
|---|
| 10 | W !!,">> Environment check complete and okay."
|
|---|
| 11 | Q
|
|---|
| 12 | ;
|
|---|
| 13 | ABRT ;Abort transport, but leave in ^XTMP
|
|---|
| 14 | S XPDABORT=2 Q
|
|---|
| 15 | ;
|
|---|
| 16 | PRE ;pre-init
|
|---|
| 17 | ;kill off ^DD(45.01,3 field, refresh field found in Build
|
|---|
| 18 | ;inorder to remove SCREEN
|
|---|
| 19 | S DIK="^DD(45.01,",DA=3,DA(1)=45.01
|
|---|
| 20 | D ^DIK
|
|---|
| 21 | Q
|
|---|
| 22 | ;
|
|---|
| 23 | POST ;post-init
|
|---|
| 24 | N DGI,DGSPEC
|
|---|
| 25 | D BMES^XPDUTL("Updating Surgical Specialty (#45.3) File.....")
|
|---|
| 26 | F DGI=1:1 S DGSPEC=$P($T(SURGSP+DGI),";;",2) Q:DGSPEC="QUIT" D
|
|---|
| 27 | . D SURGTS
|
|---|
| 28 | Q
|
|---|
| 29 | ;
|
|---|
| 30 | SURGTS ;Add/Rename to new surgical specialties
|
|---|
| 31 | D BMES^XPDUTL(">>>"_$P(DGSPEC,U,3)_">>>")
|
|---|
| 32 | ;if oldcode exists and newcode exits, then error.
|
|---|
| 33 | I $D(^DIC(45.3,"B",$P(DGSPEC,U))),$D(^DIC(45.3,"B",$P(DGSPEC,U,2))) D ERROR Q
|
|---|
| 34 | ;if no oldcode, then add newcode.
|
|---|
| 35 | I '$D(^DIC(45.3,"B",$P(DGSPEC,U))) D ADD
|
|---|
| 36 | ;if oldcode exists, then edit oldcode to newcode.
|
|---|
| 37 | I $D(^DIC(45.3,"B",$P(DGSPEC,U))) D EDIT
|
|---|
| 38 | Q
|
|---|
| 39 | ;
|
|---|
| 40 | ERROR ;
|
|---|
| 41 | D MES^XPDUTL(" Entry not added to SURGICAL SPECIALTY File (#45.3). No further updating will occur.")
|
|---|
| 42 | D MES^XPDUTL(" Please contact Customer Service for assistance.")
|
|---|
| 43 | Q
|
|---|
| 44 | ;
|
|---|
| 45 | ADD ;add surgical specialty code
|
|---|
| 46 | N DIC,DIE,DGDA1,DLAYGO,DR,X,Y
|
|---|
| 47 | S DIC="^DIC(45.3,"
|
|---|
| 48 | S DIC(0)="LX"
|
|---|
| 49 | S X=$P(DGSPEC,U,2)
|
|---|
| 50 | S DLAYGO=45.3
|
|---|
| 51 | D ^DIC
|
|---|
| 52 | S DGDA1=Y
|
|---|
| 53 | I +DGDA1=-1 D Q
|
|---|
| 54 | .D MES^XPDUTL(" Entry not added to SURGICAL SPECIALTY File (#45.3). No furher updating will occur.")
|
|---|
| 55 | .D MES^XPDUTL(" Please contact Customer Service for assistance.")
|
|---|
| 56 | .Q
|
|---|
| 57 | I $P(DGDA1,U,3)'=1&($P(Y,U,2)'=$P(DGSPEC,U,2)) D Q
|
|---|
| 58 | .D MES^XPDUTL(" Entry exists in SURGICAL SPECIALTY File (#45.3), but with a different PTF Code #.")
|
|---|
| 59 | .D MES^XPDUTL(" No further updating will occur. Please review entry.")
|
|---|
| 60 | .Q
|
|---|
| 61 | D MES^XPDUTL(" Entry "_$S($P(DGDA1,U,3)=1:"added to",1:"exists in")_" SURGICAL SPECIALTY File (#45.3).")
|
|---|
| 62 | D MES^XPDUTL(" Updating SURGICAL SPECIALTY File fields.")
|
|---|
| 63 | S DIE=DIC
|
|---|
| 64 | S DR=".01///"_$P(DGSPEC,U,2)_";1///"_$P(DGSPEC,U,3)
|
|---|
| 65 | S DA=+DGDA1
|
|---|
| 66 | D ^DIE
|
|---|
| 67 | Q
|
|---|
| 68 | ;
|
|---|
| 69 | EDIT ;rename oldcode to newcode
|
|---|
| 70 | N DA,DIE,DR
|
|---|
| 71 | S DIE="^DIC(45.3,"
|
|---|
| 72 | S DIC(0)="X"
|
|---|
| 73 | S DA=$O(^DIC(45.3,"B",$P(DGSPEC,U),""))
|
|---|
| 74 | I +DA D
|
|---|
| 75 | .S DR=".01///"_$P(DGSPEC,U,2)
|
|---|
| 76 | .D ^DIE
|
|---|
| 77 | .D MES^XPDUTL(" Entry's code "_$P(DGSPEC,U)_" renamed to code "_$P(DGSPEC,U,2))
|
|---|
| 78 | .D MES^XPDUTL(" Updating SURGICAL SPECIALTY File fields.")
|
|---|
| 79 | Q
|
|---|
| 80 | SURGSP ;;OldCode^NewCode^Specialty
|
|---|
| 81 | ;;500^48^CARDIAC SURGERY
|
|---|
| 82 | ;;501^49^TRANSPLANTATION
|
|---|
| 83 | ;;502^78^ANESTHESIOLOGY
|
|---|
| 84 | ;;QUIT
|
|---|
