- DG53757P ;ALB/MRY - Add/Rename SURGICAL SPECIALTIES ; 6/4/07 11:05am
- ;;5.3;Registration;**757,1015**;Aug 13, 1993;Build 21
- ;
- 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
- DG53757P ;ALB/MRY - Add/Rename SURGICAL SPECIALTIES ; 6/4/07 11:05am
- +1 ;;5.3;Registration;**757,1015**;Aug 13, 1993;Build 21
- +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
