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