DG53757P ;ALB/MRY - Add/Rename SURGICAL SPECIALTIES ; 6/4/07 11:05am
;;5.3;Registration;**757**;Aug 13, 1993;Build 5
;
EN ;
S XPDABORT=""
I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D G ABRT
. D BMES^XPDUTL("*****")
. D MES^XPDUTL("Your Programming variables are not set up properly.")
. D MES^XPDUTL("Installation aborted.")
W !!,">> Environment check complete and okay."
Q
;
ABRT ;Abort transport, but leave in ^XTMP
S XPDABORT=2 Q
;
PRE ;pre-init
;kill off ^DD(45.01,3 field, refresh field found in Build
;inorder to remove SCREEN
S DIK="^DD(45.01,",DA=3,DA(1)=45.01
D ^DIK
Q
;
POST ;post-init
N DGI,DGSPEC
D BMES^XPDUTL("Updating Surgical Specialty (#45.3) File.....")
F DGI=1:1 S DGSPEC=$P($T(SURGSP+DGI),";;",2) Q:DGSPEC="QUIT" D
. D SURGTS
Q
;
SURGTS ;Add/Rename to new surgical specialties
D BMES^XPDUTL(">>>"_$P(DGSPEC,U,3)_">>>")
;if oldcode exists and newcode exits, then error.
I $D(^DIC(45.3,"B",$P(DGSPEC,U))),$D(^DIC(45.3,"B",$P(DGSPEC,U,2))) D ERROR Q
;if no oldcode, then add newcode.
I '$D(^DIC(45.3,"B",$P(DGSPEC,U))) D ADD
;if oldcode exists, then edit oldcode to newcode.
I $D(^DIC(45.3,"B",$P(DGSPEC,U))) D EDIT
Q
;
ERROR ;
D MES^XPDUTL(" Entry not added to SURGICAL SPECIALTY File (#45.3). No further updating will occur.")
D MES^XPDUTL(" Please contact Customer Service for assistance.")
Q
;
ADD ;add surgical specialty code
N DIC,DIE,DGDA1,DLAYGO,DR,X,Y
S DIC="^DIC(45.3,"
S DIC(0)="LX"
S X=$P(DGSPEC,U,2)
S DLAYGO=45.3
D ^DIC
S DGDA1=Y
I +DGDA1=-1 D Q
.D MES^XPDUTL(" Entry not added to SURGICAL SPECIALTY File (#45.3). No furher updating will occur.")
.D MES^XPDUTL(" Please contact Customer Service for assistance.")
.Q
I $P(DGDA1,U,3)'=1&($P(Y,U,2)'=$P(DGSPEC,U,2)) D Q
.D MES^XPDUTL(" Entry exists in SURGICAL SPECIALTY File (#45.3), but with a different PTF Code #.")
.D MES^XPDUTL(" No further updating will occur. Please review entry.")
.Q
D MES^XPDUTL(" Entry "_$S($P(DGDA1,U,3)=1:"added to",1:"exists in")_" SURGICAL SPECIALTY File (#45.3).")
D MES^XPDUTL(" Updating SURGICAL SPECIALTY File fields.")
S DIE=DIC
S DR=".01///"_$P(DGSPEC,U,2)_";1///"_$P(DGSPEC,U,3)
S DA=+DGDA1
D ^DIE
Q
;
EDIT ;rename oldcode to newcode
N DA,DIE,DR
S DIE="^DIC(45.3,"
S DIC(0)="X"
S DA=$O(^DIC(45.3,"B",$P(DGSPEC,U),""))
I +DA D
.S DR=".01///"_$P(DGSPEC,U,2)
.D ^DIE
.D MES^XPDUTL(" Entry's code "_$P(DGSPEC,U)_" renamed to code "_$P(DGSPEC,U,2))
.D MES^XPDUTL(" Updating SURGICAL SPECIALTY File fields.")
Q
SURGSP ;;OldCode^NewCode^Specialty
;;500^48^CARDIAC SURGERY
;;501^49^TRANSPLANTATION
;;502^78^ANESTHESIOLOGY
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53757P 2750 printed Apr 09, 2024@21:39:24 Page 2
DG53757P ;ALB/MRY - Add/Rename SURGICAL SPECIALTIES ; 6/4/07 11:05am
+1 ;;5.3;Registration;**757**;Aug 13, 1993;Build 5
+2 ;
EN ;
+1 SET XPDABORT=""
+2 IF '$GET(DUZ)!($GET(DUZ(0))'="@")!('$GET(DT))!($GET(U)'="^")
Begin DoDot:1
+3 DO BMES^XPDUTL("*****")
+4 DO MES^XPDUTL("Your Programming variables are not set up properly.")
+5 DO MES^XPDUTL("Installation aborted.")
End DoDot:1
GOTO ABRT
+6 WRITE !!,">> Environment check complete and okay."
+7 QUIT
+8 ;
ABRT ;Abort transport, but leave in ^XTMP
+1 SET XPDABORT=2
QUIT
+2 ;
PRE ;pre-init
+1 ;kill off ^DD(45.01,3 field, refresh field found in Build
+2 ;inorder to remove SCREEN
+3 SET DIK="^DD(45.01,"
SET DA=3
SET DA(1)=45.01
+4 DO ^DIK
+5 QUIT
+6 ;
POST ;post-init
+1 NEW DGI,DGSPEC
+2 DO BMES^XPDUTL("Updating Surgical Specialty (#45.3) File.....")
+3 FOR DGI=1:1
SET DGSPEC=$PIECE($TEXT(SURGSP+DGI),";;",2)
if DGSPEC="QUIT"
QUIT
Begin DoDot:1
+4 DO SURGTS
End DoDot:1
+5 QUIT
+6 ;
SURGTS ;Add/Rename to new surgical specialties
+1 DO BMES^XPDUTL(">>>"_$PIECE(DGSPEC,U,3)_">>>")
+2 ;if oldcode exists and newcode exits, then error.
+3 IF $DATA(^DIC(45.3,"B",$PIECE(DGSPEC,U)))
IF $DATA(^DIC(45.3,"B",$PIECE(DGSPEC,U,2)))
DO ERROR
QUIT
+4 ;if no oldcode, then add newcode.
+5 IF '$DATA(^DIC(45.3,"B",$PIECE(DGSPEC,U)))
DO ADD
+6 ;if oldcode exists, then edit oldcode to newcode.
+7 IF $DATA(^DIC(45.3,"B",$PIECE(DGSPEC,U)))
DO EDIT
+8 QUIT
+9 ;
ERROR ;
+1 DO MES^XPDUTL(" Entry not added to SURGICAL SPECIALTY File (#45.3). No further updating will occur.")
+2 DO MES^XPDUTL(" Please contact Customer Service for assistance.")
+3 QUIT
+4 ;
ADD ;add surgical specialty code
+1 NEW DIC,DIE,DGDA1,DLAYGO,DR,X,Y
+2 SET DIC="^DIC(45.3,"
+3 SET DIC(0)="LX"
+4 SET X=$PIECE(DGSPEC,U,2)
+5 SET DLAYGO=45.3
+6 DO ^DIC
+7 SET DGDA1=Y
+8 IF +DGDA1=-1
Begin DoDot:1
+9 DO MES^XPDUTL(" Entry not added to SURGICAL SPECIALTY File (#45.3). No furher updating will occur.")
+10 DO MES^XPDUTL(" Please contact Customer Service for assistance.")
+11 QUIT
End DoDot:1
QUIT
+12 IF $PIECE(DGDA1,U,3)'=1&($PIECE(Y,U,2)'=$PIECE(DGSPEC,U,2))
Begin DoDot:1
+13 DO MES^XPDUTL(" Entry exists in SURGICAL SPECIALTY File (#45.3), but with a different PTF Code #.")
+14 DO MES^XPDUTL(" No further updating will occur. Please review entry.")
+15 QUIT
End DoDot:1
QUIT
+16 DO MES^XPDUTL(" Entry "_$SELECT($PIECE(DGDA1,U,3)=1:"added to",1:"exists in")_" SURGICAL SPECIALTY File (#45.3).")
+17 DO MES^XPDUTL(" Updating SURGICAL SPECIALTY File fields.")
+18 SET DIE=DIC
+19 SET DR=".01///"_$PIECE(DGSPEC,U,2)_";1///"_$PIECE(DGSPEC,U,3)
+20 SET DA=+DGDA1
+21 DO ^DIE
+22 QUIT
+23 ;
EDIT ;rename oldcode to newcode
+1 NEW DA,DIE,DR
+2 SET DIE="^DIC(45.3,"
+3 SET DIC(0)="X"
+4 SET DA=$ORDER(^DIC(45.3,"B",$PIECE(DGSPEC,U),""))
+5 IF +DA
Begin DoDot:1
+6 SET DR=".01///"_$PIECE(DGSPEC,U,2)
+7 DO ^DIE
+8 DO MES^XPDUTL(" Entry's code "_$PIECE(DGSPEC,U)_" renamed to code "_$PIECE(DGSPEC,U,2))
+9 DO MES^XPDUTL(" Updating SURGICAL SPECIALTY File fields.")
End DoDot:1
+10 QUIT
SURGSP ;;OldCode^NewCode^Specialty
+1 ;;500^48^CARDIAC SURGERY
+2 ;;501^49^TRANSPLANTATION
+3 ;;502^78^ANESTHESIOLOGY
+4 ;;QUIT
