ACHSRMVD ;IHS/OIT/FCJ - REMOVE DOC CAUSING THE DUPLICATE DOC ERROR;JUL 10, 2008
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13,14,21**;JUN 11,2001;Build 43
;ACHS*3.1*13 IHS/OIT/FCJ NEW ROUTINE FOR PATCH 13
;ACHS*3.1*14 IHS/OIT/FCJ
ST ;
W @IOF
W ?5,"This routine removes documents that have been added",!
W ?5,"after the site manager has removed the entire fiscal",!
W ?5,"year documents. You will need to enter the 4 digit",!
W ?5,"fiscal year. The duplicate documents will then be",!
W ?5,"displayed. You will need to confirm deletion of the",!
W ?5,"documents.",!!
W ?5,"NOTE: FY ON DISPLAYED DOCUMENTS SHOULD DISPLAY 10 YRS PRIOR TO FY ENTERED,",!
W ?5,"EXAMPLE: IF 2008 ENTERED THEN THE FY: 1998 SHOULD DISPLAY FOR DOCUMENTS."
W !
FY ;Enter FY to remove documents from
S DIR(0)="N^1996:"_ACHSCFY,DIR("A")="Enter the 4 digit FY the duplicate error is occurring in"
D ^DIR K DIR
G:$D(DIRUT) EXT
G:Y<1 FY
S ACHSEFY=Y
;
PROC ; Beg process to display and delete documents
;ACHS*3.1*14 IHS/OIT/FCJ USER READ PROMPT AS CURRENT FY
S (ACHSTMP,ACHSDOC)=""
I '$D(^ACHS(9,DUZ(2),"FY",ACHSEFY)) W !,"This FY is not valid for this facility" G FY
S (ACHSTMP,ACHSDOC)=1_$E(ACHSEFY,4)_"00000"+$P(^ACHS(9,DUZ(2),"FY",ACHSEFY,"C"),U) ;BEG DOC NUMBER
;I $D(^ACHS(9,DUZ(2),"FY",ACHSEFY)) S (ACHSTMP,ACHSDOC)=1_$E(ACHSEFY,4)_"00000"+$P(^ACHS(9,DUZ(2),"FY",ACHSEFY,"C"),U)
;I ACHSDOC="",ACHSEFY+10'>ACHSCFY S (ACHSTMP,ACHSDOC)=1_$E(ACHSEFY,4)_"00000"+$P(^ACHS(9,DUZ(2),"FY",ACHSEFY+10,"C"),U)
W !,"Documents to be Removed:"
S ACHSCTN=0,LISTCNT=1
I ACHSDOC'="" D LOOP
I LISTCNT=1 W !,"There are no documents to be removed...." D RTRN^ACHS G EXT
S DIR(0)="Y",DIR("A")="Would you like to continue with deletion of these documents",DIR("B")="N"
D ^DIR K DIR
I Y=1 S ACHSCTN=1,LISTCNT=1 W !,"Deleting Documents: " D LOOP
G EXT
Q
LOOP ;
F S ACHSDOC=$O(^ACHSF(DUZ(2),"D","B",ACHSDOC)) Q:(ACHSDOC'?1N.N)!($E(ACHSDOC,2)>$E(ACHSEFY,4)) D
. S ACHSDIEN=0
. F S ACHSDIEN=$O(^ACHSF(DUZ(2),"D","B",ACHSDOC,ACHSDIEN)) Q:ACHSDIEN'?1N.N D
. .D DSPL
I ACHSCTN=1 W !,"Removed ",LISTCNT-1," Documents"
S ACHSDOC=ACHSTMP
Q
DSPL ;Display document information
;ACHS*3.1*21 ADDED NXT 3 LINES FOR TESTING FOR INDX W/O DATA
I '$D(^ACHSF(DUZ(2),"D",ACHSDIEN)) D Q
.W !,"Index with no data ",ACHSDOC," Index removed",!
.K ^ACHSF(DUZ(2),"D","B",ACHSDOC,ACHSDIEN)
W !,LISTCNT,". Document: "
S Y=ACHSDIEN D Q3^ACHSUD
S Y=$P(DOCDATA,U,2) X ^DD("DD")
W !?13," FY: ",$P(DOCDATA,U,27)," Date Entered: ",Y
Q:'ACHSCTN
DEL ;Delete the records
S DIK="^ACHSF("_DUZ(2)_",""D"",",DA(1)=DUZ(2),DA=ACHSDIEN
D ^DIK K DIK
W " DELETED"
Q
EXT ;
K ACHSDOC,ACHSTMP,ACHSCTN,ACHSDIEN,LISTCNT,DOCDATA,ACHSEFY
Q
ACHSRMVD ;IHS/OIT/FCJ - REMOVE DOC CAUSING THE DUPLICATE DOC ERROR;JUL 10, 2008
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13,14,21**;JUN 11,2001;Build 43
+2 ;ACHS*3.1*13 IHS/OIT/FCJ NEW ROUTINE FOR PATCH 13
+3 ;ACHS*3.1*14 IHS/OIT/FCJ
ST ;
+1 WRITE @IOF
+2 WRITE ?5,"This routine removes documents that have been added",!
+3 WRITE ?5,"after the site manager has removed the entire fiscal",!
+4 WRITE ?5,"year documents. You will need to enter the 4 digit",!
+5 WRITE ?5,"fiscal year. The duplicate documents will then be",!
+6 WRITE ?5,"displayed. You will need to confirm deletion of the",!
+7 WRITE ?5,"documents.",!!
+8 WRITE ?5,"NOTE: FY ON DISPLAYED DOCUMENTS SHOULD DISPLAY 10 YRS PRIOR TO FY ENTERED,",!
+9 WRITE ?5,"EXAMPLE: IF 2008 ENTERED THEN THE FY: 1998 SHOULD DISPLAY FOR DOCUMENTS."
+10 WRITE !
FY ;Enter FY to remove documents from
+1 SET DIR(0)="N^1996:"_ACHSCFY
SET DIR("A")="Enter the 4 digit FY the duplicate error is occurring in"
+2 DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO EXT
+4 IF Y<1
GOTO FY
+5 SET ACHSEFY=Y
+6 ;
PROC ; Beg process to display and delete documents
+1 ;ACHS*3.1*14 IHS/OIT/FCJ USER READ PROMPT AS CURRENT FY
+2 SET (ACHSTMP,ACHSDOC)=""
+3 IF '$DATA(^ACHS(9,DUZ(2),"FY",ACHSEFY))
WRITE !,"This FY is not valid for this facility"
GOTO FY
+4 ;BEG DOC NUMBER
SET (ACHSTMP,ACHSDOC)=1_$EXTRACT(ACHSEFY,4)_"00000"+$PIECE(^ACHS(9,DUZ(2),"FY",ACHSEFY,"C"),U)
+5 ;I $D(^ACHS(9,DUZ(2),"FY",ACHSEFY)) S (ACHSTMP,ACHSDOC)=1_$E(ACHSEFY,4)_"00000"+$P(^ACHS(9,DUZ(2),"FY",ACHSEFY,"C"),U)
+6 ;I ACHSDOC="",ACHSEFY+10'>ACHSCFY S (ACHSTMP,ACHSDOC)=1_$E(ACHSEFY,4)_"00000"+$P(^ACHS(9,DUZ(2),"FY",ACHSEFY+10,"C"),U)
+7 WRITE !,"Documents to be Removed:"
+8 SET ACHSCTN=0
SET LISTCNT=1
+9 IF ACHSDOC'=""
DO LOOP
+10 IF LISTCNT=1
WRITE !,"There are no documents to be removed...."
DO RTRN^ACHS
GOTO EXT
+11 SET DIR(0)="Y"
SET DIR("A")="Would you like to continue with deletion of these documents"
SET DIR("B")="N"
+12 DO ^DIR
KILL DIR
+13 IF Y=1
SET ACHSCTN=1
SET LISTCNT=1
WRITE !,"Deleting Documents: "
DO LOOP
+14 GOTO EXT
+15 QUIT
LOOP ;
+1 FOR
SET ACHSDOC=$ORDER(^ACHSF(DUZ(2),"D","B",ACHSDOC))
IF (ACHSDOC'?1N.N)!($EXTRACT(ACHSDOC,2)>$EXTRACT(ACHSEFY,4))
QUIT
Begin DoDot:1
+2 SET ACHSDIEN=0
+3 FOR
SET ACHSDIEN=$ORDER(^ACHSF(DUZ(2),"D","B",ACHSDOC,ACHSDIEN))
IF ACHSDIEN'?1N.N
QUIT
Begin DoDot:2
+4 DO DSPL
End DoDot:2
End DoDot:1
+5 IF ACHSCTN=1
WRITE !,"Removed ",LISTCNT-1," Documents"
+6 SET ACHSDOC=ACHSTMP
+7 QUIT
DSPL ;Display document information
+1 ;ACHS*3.1*21 ADDED NXT 3 LINES FOR TESTING FOR INDX W/O DATA
+2 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN))
Begin DoDot:1
+3 WRITE !,"Index with no data ",ACHSDOC," Index removed",!
+4 KILL ^ACHSF(DUZ(2),"D","B",ACHSDOC,ACHSDIEN)
End DoDot:1
QUIT
+5 WRITE !,LISTCNT,". Document: "
+6 SET Y=ACHSDIEN
DO Q3^ACHSUD
+7 SET Y=$PIECE(DOCDATA,U,2)
XECUTE ^DD("DD")
+8 WRITE !?13," FY: ",$PIECE(DOCDATA,U,27)," Date Entered: ",Y
+9 IF 'ACHSCTN
QUIT
DEL ;Delete the records
+1 SET DIK="^ACHSF("_DUZ(2)_",""D"","
SET DA(1)=DUZ(2)
SET DA=ACHSDIEN
+2 DO ^DIK
KILL DIK
+3 WRITE " DELETED"
+4 QUIT
EXT ;
+1 KILL ACHSDOC,ACHSTMP,ACHSCTN,ACHSDIEN,LISTCNT,DOCDATA,ACHSEFY
+2 QUIT
