- 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 Feb 19, 2025@00:13:15 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$$