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

ACHSYFYD.m

Go to the documentation of this file. 
  1. ACHSYFYD ; IHS/ITSC/PMF - DELETE DOCUMENTS FOR SELECTED FY ;    [ 10/16/2001   8:16 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
  1.  ;
  1.  ;IHS/ITSC/PMF  1/12/01  changed manipulation of DUZ array
  1.  ;to something less objectionable
  1.  ;
  1.  ;
  1.  ;;This routine will call XBGSAVE to save the global that contains   
  1.  ;;the CHS documents, ^ACHSF(, for the CHS FACILITY file.
  1.  ;;
  1.  ;;You will then be prompted for which FY docs to delete.
  1.  ;;
  1.  ;;Then, it will $ORDER thru the document cross reference for EACH
  1.  ;;facility in your CHS FACILITY file, and *_DELETE_* all P.O.'s for
  1.  ;;the selected FY, if the date of the order is more than 3 years ago.
  1.  ;;The selected FY will also be deleted from the CHS DATA CONTROL file.
  1.  ;;
  1.  ;;Deletion is necessary because it will be impossible to enter
  1.  ;;documents for a FY if you have documents for a previous FY
  1.  ;;that ends in the same digit.  This is because of the design
  1.  ;;limitations of the software, i.e., using only the last digit
  1.  ;;of the fiscal year.  Be not disturbed:  current fiscal
  1.  ;;authority does not extend to 10 years, anyway.
  1.  ;;
  1.  ;;If you have any doubts, please call the developer at 505-248-4191
  1.  ;;prior to running this utility.
  1.  ;;###
  1.  ;
  1. START ;
  1.  I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." Q
  1.  I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." Q
  1.  I '$G(DUZ(2)) W !,"DUZ(2) UNDEFINED OR 0." Q
  1.  ;
  1.  D HELP("ACHSYFYD")
  1.  Q:'$$DIR^XBDIR("E")
  1.  D ^ACHSVAR
  1.  N ACHSFY
  1. FY ;
  1.  S ACHSFY=$$FYSEL^ACHS
  1.  Q:$D(DUOUT)!$D(DTOUT)!('ACHSFY)
  1.  I ACHSCFY-ACHSFY<7 W *7,!,"Must be more than 6 Fiscal Years ago." Q:'$$DIR^XBDIR("E")  G FY
  1.  ;
  1.  D HELP("SAVE")
  1.  N XBFLG
  1.  S XBGL="ACHSF"  ;name of global (mandatory, all others optional)
  1.  S XBMED="F"     ;media to which to save global (user asked, if not exist)
  1.  S XBFN="ACHSF.SAV"  ;output file name, default "<ns><asufac>.<JulianDate>"
  1.  S XBTLE="Save of CHS FACILITY file, ^ACHSF(, for deletion of FY "_ACHSFY_" documents"     ;comment for dump header (facility name is concatenated)
  1.  S XBQ="N" ;Y/N, to place file in uucp q, default "Y"
  1.  D ^XBGSAVE
  1.  I XBFLG W !?5,"GLOBAL SAVE FAILED!!",!!,"Reason :  '",$G(XBFLG(1)),"'." Q
  1.  D HELP("SAVEOK")
  1.  ;
  1.  Q:'$$DIR^XBDIR("E")
  1.  D HELP("DEL")
  1.  ;
  1.  N ACHS,ACHSDUZ2,ACHSY,DA,DIK,FAC
  1.  S ACHSCTR=0
  1.  S ACHSY=$E(ACHSFY,4)
  1.  S FAC=0
  1.  ;
  1.  F  S FAC=$O(^ACHSF("B",FAC)) Q:'FAC  S DA(1)=FAC,ACHS="1"_ACHSY_"00000" F  S ACHS=$O(^ACHSF(FAC,"D","B",ACHS)) Q:'($E(ACHS,2)=ACHSY)  S DA=$O(^(ACHS,0)) D
  1.  . I DA,$D(^ACHSF(FAC,"D",DA,0)),$P(^(0),U,2)<(DT-30000) S DIK="^ACHSF("_DA(1)_",""D""," D ^DIK W "." S ACHSCTR=ACHSCTR+1
  1.  .Q
  1.  ;
  1.  ;10/30/00 pmf  - at this point, the "ES" cross reference survives
  1.  ;the kill being done by the loop just above here.  So we will clean
  1.  ;them up now.
  1.  S G="" F  S G=$O(^ACHSF("B",G)) Q:G=""  S G1="" F  S G1=$O(^ACHSF(G,"ES",G1)) Q:G1=""  S G2="" F  S G2=$O(^ACHSF(G,"ES",G1,G2)) Q:G2=""  I '$D(^ACHSF(G,"D",G2)) K ^ACHSF(G,"ES",G1,G2) W "."
  1.  ;
  1.  W !,ACHSCTR," FY ",ACHSFY," documents permanently deleted.",!
  1.  ;
  1.  W !,"Deleting FY ",ACHSFY," from the CHS DATA CONTROL FILE."
  1.  D WAIT^DICD
  1.  ;
  1.  ;RE-INDEX THE FILE
  1.  S DIK="^ACHS(9,"_DUZ(2)_",""FY"","
  1.  S DA(1)=DUZ(2)
  1.  S DA=ACHSFY
  1.  D ^DIK
  1.  ;
  1.  Q
  1.  ;
  1. HELP(L) ;EP - Display text at label L.
  1.  W !
  1.  F %=1:1 W !?4,$P($T(@L+%),";",3) Q:$P($T(@L+%+1),";",3)="###"
  1.  Q
  1.  ;
  1. SAVE ;
  1.  ;;Saving the CHS FACILITY file global, ^ACHSF(.
  1.  ;;This could take 'awhile'.
  1.  ;;Why don't you go for coffee.....
  1.  ;;###
  1.  ;
  1. SAVEOK ;
  1.  ;;Remember that if you have to restore the global, the cross references
  1.  ;;on the entire file will not be there because XBGSAVE stops when the
  1.  ;;first subscript is not a numeric.  So, use FileMan to re-cross
  1.  ;;index the entire CHS FACILITY file, if you really have to restore the
  1.  ;;global.
  1.  ;;###
  1.  ;
  1. DEL ;
  1.  ;10/30/00  PMF  remove this line, replace it with the next line - ;;OK.  Here we go with the deletions of FY 86 docs.
  1.  ;;OK.  Here we go with the deletion
  1.  ;;This could take awhile.
  1.  ;;Have another cup of coffee.....
  1.  ;;###
  1.  ;