Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SD599PT

SD599PT.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. Q
  1. ;
  1. EN ; --- main entry point
  1. S U="^"
  1. D BMES^XPDUTL("Post-Init Started...")
  1. ;
  1. ; -- main driver calls
  1. D HL
  1. ;
  1. D BMES^XPDUTL("Post-Init Finished.")
  1. Q
  1. ;
  1. HL ; -- delete HOSPITIAL LOCATION (#44) fields and related data
  1. N SDARY,SDIEN
  1. ;
  1. D BMES^XPDUTL(" >>> Deleting HOSPITAL LOCATION (#44) fields...")
  1. ;
  1. ; -- get fields to delete
  1. D BUILDR(44,.SDARY)
  1. ;
  1. IF '$O(SDARY(0)) D MES^XPDUTL(" -> Fields already deleted.") Q
  1. ;
  1. ; -- delete data
  1. S SDIEN=0
  1. F S SDIEN=$O(^SC(SDIEN)) Q:'SDIEN D
  1. . N SDFDA,SDFLD
  1. . S SDFLD=0
  1. . F S SDFLD=$O(SDARY(SDFLD)) Q:'SDFLD D
  1. . . I SDFLD=25,$D(^SC("AE",1,SDIEN)) D Q ;Re file data associated with field 2802 global position 25
  1. . . . S SDFDA(44,SDIEN_",",SDFLD)=1
  1. . . . D FILE^DIE("S","SDFDA")
  1. . . S SDFDA(44,SDIEN_",",SDFLD)="@"
  1. . D FILE^DIE("S","SDFDA")
  1. I $D(^SC("AF")) K ^("AF") ;if "AF" xref still exists after file edit. Delete entire xref.
  1. ;
  1. ; -- delete dds
  1. D DELDD(44)
  1. D MES^XPDUTL(" >>> Done.")
  1. Q
  1. ;
  1. BUILDR(SDD,SDARY) ; -- build array of fields to delete
  1. N SDI,SDX,SDENDFLG
  1. S SDENDFLG="$$END$$"
  1. ;
  1. F SDI=1:1 S SDX=$P($T(FLDS+SDI),";;",2) Q:SDX=SDENDFLG D
  1. . N SDFILE,SDFLD
  1. . S SDFILE=+SDX
  1. . S SDFLD=+$P(SDX,U,2)
  1. . S SDNAME=$P(SDX,U,3)
  1. . IF SDD=SDFILE,$$LABEL(SDFILE,SDFLD)=SDNAME D
  1. . . S SDARY(SDFLD)=""
  1. Q
  1. ;
  1. DELDD(SDD) ; -- tool to delete fields dd
  1. ; -- delete dd
  1. N SDI,SDX,SDENDFLG,SDCNT
  1. S SDENDFLG="$$END$$"
  1. S SDCNT=0
  1. ;
  1. ; -- delete dds
  1. F SDI=1:1 S SDX=$P($T(FLDS+SDI),";;",2) Q:SDX=SDENDFLG D
  1. . N SDFILE,SDFLD,SDNAME
  1. . S SDFILE=+SDX
  1. . S SDFLD=+$P(SDX,U,2)
  1. . S SDNAME=$P(SDX,U,3)
  1. . ;
  1. . ; -- make sure field is not reused before deleting
  1. . IF SDD=SDFILE,$$LABEL(SDFILE,SDFLD)=SDNAME D
  1. . . N DIK,DA
  1. . . S DIK="^DD("_SDD_",",DA=SDFLD,DA(1)=SDD D ^DIK
  1. . . D MSG(SDFLD,SDNAME)
  1. . . S SDCNT=SDCNT+1
  1. ;
  1. IF 'SDCNT D MES^XPDUTL(" -> Fields already deleted.")
  1. Q
  1. ;
  1. LABEL(SDFILE,SDFLD) ; -- get label if not deleted
  1. N SDY
  1. D FIELD^DID(SDFILE,SDFLD,"N","LABEL","SDY")
  1. Q $G(SDY("LABEL"))
  1. ;
  1. MSG(SDFLD,SDNAME) ; -- tell user (use kids call??)
  1. D MES^XPDUTL(" -> Field '"_SDFLD_" - "_SDNAME_"' deleted.")
  1. Q
  1. ;
  1. FLDS ; -- fields to be deleted [ file# ^ field# ^ field label ]
  1. ;;44^25^PROCEDURE CHECK-OFF SHEET
  1. ;;44^26^ASK PROVIDER AT CHECK OUT
  1. ;;44^27^ASK DIAGNOSIS AT CHECK OUT
  1. ;;44^28^ASK STOP CODES AT CHECK OUT
  1. ;;$$END$$