SD599PT ;ALB/RJS - Patch SD*5.3*599 Post-Init Routine ; 8/13/12 11:08am
;;5.3;Scheduling;**599**;Aug 13, 1993;Build 11
;
Q
;
EN ; --- main entry point
S U="^"
D BMES^XPDUTL("Post-Init Started...")
;
; -- main driver calls
D HL
;
D BMES^XPDUTL("Post-Init Finished.")
Q
;
HL ; -- delete HOSPITIAL LOCATION (#44) fields and related data
N SDARY,SDIEN
;
D BMES^XPDUTL(" >>> Deleting HOSPITAL LOCATION (#44) fields...")
;
; -- get fields to delete
D BUILDR(44,.SDARY)
;
IF '$O(SDARY(0)) D MES^XPDUTL(" -> Fields already deleted.") Q
;
; -- delete data
S SDIEN=0
F S SDIEN=$O(^SC(SDIEN)) Q:'SDIEN D
. N SDFDA,SDFLD
. S SDFLD=0
. F S SDFLD=$O(SDARY(SDFLD)) Q:'SDFLD D
. . I SDFLD=25,$D(^SC("AE",1,SDIEN)) D Q ;Re file data associated with field 2802 global position 25
. . . S SDFDA(44,SDIEN_",",SDFLD)=1
. . . D FILE^DIE("S","SDFDA")
. . S SDFDA(44,SDIEN_",",SDFLD)="@"
. D FILE^DIE("S","SDFDA")
I $D(^SC("AF")) K ^("AF") ;if "AF" xref still exists after file edit. Delete entire xref.
;
; -- delete dds
D DELDD(44)
D MES^XPDUTL(" >>> Done.")
Q
;
BUILDR(SDD,SDARY) ; -- build array of fields to delete
N SDI,SDX,SDENDFLG
S SDENDFLG="$$END$$"
;
F SDI=1:1 S SDX=$P($T(FLDS+SDI),";;",2) Q:SDX=SDENDFLG D
. N SDFILE,SDFLD
. S SDFILE=+SDX
. S SDFLD=+$P(SDX,U,2)
. S SDNAME=$P(SDX,U,3)
. IF SDD=SDFILE,$$LABEL(SDFILE,SDFLD)=SDNAME D
. . S SDARY(SDFLD)=""
Q
;
DELDD(SDD) ; -- tool to delete fields dd
; -- delete dd
N SDI,SDX,SDENDFLG,SDCNT
S SDENDFLG="$$END$$"
S SDCNT=0
;
; -- delete dds
F SDI=1:1 S SDX=$P($T(FLDS+SDI),";;",2) Q:SDX=SDENDFLG D
. N SDFILE,SDFLD,SDNAME
. S SDFILE=+SDX
. S SDFLD=+$P(SDX,U,2)
. S SDNAME=$P(SDX,U,3)
. ;
. ; -- make sure field is not reused before deleting
. IF SDD=SDFILE,$$LABEL(SDFILE,SDFLD)=SDNAME D
. . N DIK,DA
. . S DIK="^DD("_SDD_",",DA=SDFLD,DA(1)=SDD D ^DIK
. . D MSG(SDFLD,SDNAME)
. . S SDCNT=SDCNT+1
;
IF 'SDCNT D MES^XPDUTL(" -> Fields already deleted.")
Q
;
LABEL(SDFILE,SDFLD) ; -- get label if not deleted
N SDY
D FIELD^DID(SDFILE,SDFLD,"N","LABEL","SDY")
Q $G(SDY("LABEL"))
;
MSG(SDFLD,SDNAME) ; -- tell user (use kids call??)
D MES^XPDUTL(" -> Field '"_SDFLD_" - "_SDNAME_"' deleted.")
Q
;
FLDS ; -- fields to be deleted [ file# ^ field# ^ field label ]
;;44^25^PROCEDURE CHECK-OFF SHEET
;;44^26^ASK PROVIDER AT CHECK OUT
;;44^27^ASK DIAGNOSIS AT CHECK OUT
;;44^28^ASK STOP CODES AT CHECK OUT
;;$$END$$
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSD599PT 2552 printed Apr 09, 2024@21:46:13 Page 2
SD599PT ;ALB/RJS - Patch SD*5.3*599 Post-Init Routine ; 8/13/12 11:08am
+1 ;;5.3;Scheduling;**599**;Aug 13, 1993;Build 11
+2 ;
+3 QUIT
+4 ;
EN ; --- main entry point
+1 SET U="^"
+2 DO BMES^XPDUTL("Post-Init Started...")
+3 ;
+4 ; -- main driver calls
+5 DO HL
+6 ;
+7 DO BMES^XPDUTL("Post-Init Finished.")
+8 QUIT
+9 ;
HL ; -- delete HOSPITIAL LOCATION (#44) fields and related data
+1 NEW SDARY,SDIEN
+2 ;
+3 DO BMES^XPDUTL(" >>> Deleting HOSPITAL LOCATION (#44) fields...")
+4 ;
+5 ; -- get fields to delete
+6 DO BUILDR(44,.SDARY)
+7 ;
+8 IF '$ORDER(SDARY(0))
DO MES^XPDUTL(" -> Fields already deleted.")
QUIT
+9 ;
+10 ; -- delete data
+11 SET SDIEN=0
+12 FOR
SET SDIEN=$ORDER(^SC(SDIEN))
if 'SDIEN
QUIT
Begin DoDot:1
+13 NEW SDFDA,SDFLD
+14 SET SDFLD=0
+15 FOR
SET SDFLD=$ORDER(SDARY(SDFLD))
if 'SDFLD
QUIT
Begin DoDot:2
+16 ;Re file data associated with field 2802 global position 25
IF SDFLD=25
IF $DATA(^SC("AE",1,SDIEN))
Begin DoDot:3
+17 SET SDFDA(44,SDIEN_",",SDFLD)=1
+18 DO FILE^DIE("S","SDFDA")
End DoDot:3
QUIT
+19 SET SDFDA(44,SDIEN_",",SDFLD)="@"
End DoDot:2
+20 DO FILE^DIE("S","SDFDA")
End DoDot:1
+21 ;if "AF" xref still exists after file edit. Delete entire xref.
IF $DATA(^SC("AF"))
KILL ^("AF")
+22 ;
+23 ; -- delete dds
+24 DO DELDD(44)
+25 DO MES^XPDUTL(" >>> Done.")
+26 QUIT
+27 ;
BUILDR(SDD,SDARY) ; -- build array of fields to delete
+1 NEW SDI,SDX,SDENDFLG
+2 SET SDENDFLG="$$END$$"
+3 ;
+4 FOR SDI=1:1
SET SDX=$PIECE($TEXT(FLDS+SDI),";;",2)
if SDX=SDENDFLG
QUIT
Begin DoDot:1
+5 NEW SDFILE,SDFLD
+6 SET SDFILE=+SDX
+7 SET SDFLD=+$PIECE(SDX,U,2)
+8 SET SDNAME=$PIECE(SDX,U,3)
+9 IF SDD=SDFILE
IF $$LABEL(SDFILE,SDFLD)=SDNAME
Begin DoDot:2
+10 SET SDARY(SDFLD)=""
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
DELDD(SDD) ; -- tool to delete fields dd
+1 ; -- delete dd
+2 NEW SDI,SDX,SDENDFLG,SDCNT
+3 SET SDENDFLG="$$END$$"
+4 SET SDCNT=0
+5 ;
+6 ; -- delete dds
+7 FOR SDI=1:1
SET SDX=$PIECE($TEXT(FLDS+SDI),";;",2)
if SDX=SDENDFLG
QUIT
Begin DoDot:1
+8 NEW SDFILE,SDFLD,SDNAME
+9 SET SDFILE=+SDX
+10 SET SDFLD=+$PIECE(SDX,U,2)
+11 SET SDNAME=$PIECE(SDX,U,3)
+12 ;
+13 ; -- make sure field is not reused before deleting
+14 IF SDD=SDFILE
IF $$LABEL(SDFILE,SDFLD)=SDNAME
Begin DoDot:2
+15 NEW DIK,DA
+16 SET DIK="^DD("_SDD_","
SET DA=SDFLD
SET DA(1)=SDD
DO ^DIK
+17 DO MSG(SDFLD,SDNAME)
+18 SET SDCNT=SDCNT+1
End DoDot:2
End DoDot:1
+19 ;
+20 IF 'SDCNT
DO MES^XPDUTL(" -> Fields already deleted.")
+21 QUIT
+22 ;
LABEL(SDFILE,SDFLD) ; -- get label if not deleted
+1 NEW SDY
+2 DO FIELD^DID(SDFILE,SDFLD,"N","LABEL","SDY")
+3 QUIT $GET(SDY("LABEL"))
+4 ;
MSG(SDFLD,SDNAME) ; -- tell user (use kids call??)
+1 DO MES^XPDUTL(" -> Field '"_SDFLD_" - "_SDNAME_"' deleted.")
+2 QUIT
+3 ;
FLDS ; -- fields to be deleted [ file# ^ field# ^ field label ]
+1 ;;44^25^PROCEDURE CHECK-OFF SHEET
+2 ;;44^26^ASK PROVIDER AT CHECK OUT
+3 ;;44^27^ASK DIAGNOSIS AT CHECK OUT
+4 ;;44^28^ASK STOP CODES AT CHECK OUT
+5 ;;$$END$$
