source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DG53757P.m@ 1578

Last change on this file since 1578 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.6 KB
Line 
1DG53757P ;ALB/MRY - Add/Rename SURGICAL SPECIALTIES ; 6/4/07 11:05am
2 ;;5.3;Registration;**757**;Aug 13, 1993;Build 5
3 ;
4EN ;
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 ;
13ABRT ;Abort transport, but leave in ^XTMP
14 S XPDABORT=2 Q
15 ;
16PRE ;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 ;
23POST ;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 ;
30SURGTS ;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 ;
40ERROR ;
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 ;
45ADD ;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 ;
69EDIT ;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
80SURGSP ;;OldCode^NewCode^Specialty
81 ;;500^48^CARDIAC SURGERY
82 ;;501^49^TRANSPLANTATION
83 ;;502^78^ANESTHESIOLOGY
84 ;;QUIT
Note: See TracBrowser for help on using the repository browser.