ACHSYCX ; IHS/ITSC/PMF - CROSS REFERENCE CLEANUP FOR CHS FACILITY FILE ; [ 04/19/2002 12:14 PM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**4**;JUN 11, 2001
;ACHS*3.1*4 whole routine is new
;
;look for cross references to documents that are not there and
;kill them. this utility does not check xrefs down to the trans
;level, just the doc level. So if a xref points to a doc that
;is there and a transaction that is not there, nothing is done.
;
;the xrefs all have their name, i.e., TB, in subscript 2 except
;for AC, where it is ss 1, and B, where it is ss 2. the routine
;is generic enough to handle that
;
;EOBR has the document pointer in position 3
;B and TB have doc pointer in position 5
;the rest have doc pointer in position 4
;
;if the flag MOCK is set, it means we've entered from another
;routine and we will not kill anything, just find the buggers
;
S DOLH=$H,DOLH=$TR(DOLH,",","_")
S MOCK=$G(MOCK)
K COUNT
;
;before we get started, clean up anything this util stored
;in ^TEMP more than 90 days ago
S XDOLH="" F S XDOLH=$O(^TEMP("ACHSCLXR",XDOLH)) Q:XDOLH="" Q:((XDOLH+3)>+DOLH) K ^TEMP("ACHSCLXR",XDOLH)
;
F XREF="AC","B","EOBD","EOBP","EOBR","ES","PB","PDOS","TB","VB" D CLEAN
;
I MOCK W !!!,"This was a trial run and no actual changes were made",!,"These numbers are counts only"
W !!!,"Number of cross references examined:",?50,+$G(COUNT("TOTCHK"))
W !!,"Total number of cross references removed:",?50,+$G(COUNT("KILL"))
W !
F XREF="AC","B","EOBD","EOBP","EOBR","ES","PB","PDOS","TB","VB" W !,"For cross reference ",XREF,":",?50,+$G(COUNT(XREF))
W !!
S ^TEMP("ACHSCLXR",DOLH)=$H
;
K COUNT,DOLH,FAC,MOCK,SS1,SS2,SS3,SS4,SS5,XREF,XDOLH
Q
;
CLEAN ;
;handle AC as a special case, since it appears in the first
;subscript position
I XREF="AC" S SS1="AC" D CLEAN2 Q
S SS1=0 F S SS1=$O(^ACHSF(SS1)) Q:'SS1 D CLEAN2
Q
;
CLEAN2 ;
I XREF="B" S SS2="D" D CLEAN3 Q
I XREF'="AC" S SS2=XREF D CLEAN3 Q
S SS2="" F S SS2=$O(^ACHSF(SS1,SS2)) Q:SS2="" D CLEAN3
Q
;
CLEAN3 ;
I XREF="B" S SS3=XREF D CLEAN4 Q
S SS3="" F S SS3=$O(^ACHSF(SS1,SS2,SS3)) Q:SS3="" D CLEAN4
Q
;
CLEAN4 ;
;we can now identify the facility code. It's in subscript 1
;unless the cross reference is AC, then it's in ss 3.
;
I XREF="AC" S FAC=SS3
E S FAC=SS1
;
;for cross reference EOBR, doc pointer is in ss3, so we are
;ready to test
I XREF="EOBR" D Q
. S COUNT("TOTCHK")=$G(COUNT("TOTCHK"))+1 I COUNT("TOTCHK")#500=0 W " ."
. I $D(^ACHSF(FAC,"D",SS3)) Q
. M ^TEMP("ACHSCLXR",DOLH,SS1,SS2,SS3)=^ACHSF(SS1,SS2,SS3)
. S COUNT("KILL")=$G(COUNT("KILL"))+1
. S COUNT(XREF)=$G(COUNT(XREF))+1
. I MOCK Q
. K ^ACHSF(SS1,SS2,SS3)
. Q
S SS4="" F S SS4=$O(^ACHSF(SS1,SS2,SS3,SS4)) Q:SS4="" D CLEAN5
Q
;
CLEAN5 ;
;all of the cross references have the doc pointer in ss4, except
;EOBR, which is already done, and TB and B, which are handled as
;exceptions
;
I XREF'="TB",(XREF'="B") D Q
. S COUNT("TOTCHK")=$G(COUNT("TOTCHK"))+1 I COUNT("TOTCHK")#500=0 W " ."
. I $D(^ACHSF(FAC,"D",SS4)) Q
. M ^TEMP("ACHSCLXR",DOLH,SS1,SS2,SS3,SS4)=^ACHSF(SS1,SS2,SS3,SS4)
. S COUNT("KILL")=$G(COUNT("KILL"))+1
. S COUNT(XREF)=$G(COUNT(XREF))+1
. I MOCK Q
. K ^ACHSF(SS1,SS2,SS3,SS4)
. Q
S SS5="" F S SS5=$O(^ACHSF(SS1,SS2,SS3,SS4,SS5)) Q:SS5="" D CLEAN6
Q
;
CLEAN6 ;
S COUNT("TOTCHK")=$G(COUNT("TOTCHK"))+1 I COUNT("TOTCHK")#500=0 W " ."
I $D(^ACHSF(FAC,"D",SS5)) Q
M ^TEMP("ACHSCLXR",DOLH,SS1,SS2,SS3,SS4,SS5)=^ACHSF(SS1,SS2,SS3,SS4,SS5)
S COUNT("KILL")=$G(COUNT("KILL"))+1
S COUNT(XREF)=$G(COUNT(XREF))+1
I MOCK Q
K ^ACHSF(SS1,SS2,SS3,SS4,SS5)
Q
ACHSYCX ; IHS/ITSC/PMF - CROSS REFERENCE CLEANUP FOR CHS FACILITY FILE ; [ 04/19/2002 12:14 PM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**4**;JUN 11, 2001
+2 ;ACHS*3.1*4 whole routine is new
+3 ;
+4 ;look for cross references to documents that are not there and
+5 ;kill them. this utility does not check xrefs down to the trans
+6 ;level, just the doc level. So if a xref points to a doc that
+7 ;is there and a transaction that is not there, nothing is done.
+8 ;
+9 ;the xrefs all have their name, i.e., TB, in subscript 2 except
+10 ;for AC, where it is ss 1, and B, where it is ss 2. the routine
+11 ;is generic enough to handle that
+12 ;
+13 ;EOBR has the document pointer in position 3
+14 ;B and TB have doc pointer in position 5
+15 ;the rest have doc pointer in position 4
+16 ;
+17 ;if the flag MOCK is set, it means we've entered from another
+18 ;routine and we will not kill anything, just find the buggers
+19 ;
+20 SET DOLH=$HOROLOG
SET DOLH=$TRANSLATE(DOLH,",","_")
+21 SET MOCK=$GET(MOCK)
+22 KILL COUNT
+23 ;
+24 ;before we get started, clean up anything this util stored
+25 ;in ^TEMP more than 90 days ago
+26 SET XDOLH=""
FOR
SET XDOLH=$ORDER(^TEMP("ACHSCLXR",XDOLH))
IF XDOLH=""
QUIT
IF ((XDOLH+3)>+DOLH)
QUIT
KILL ^TEMP("ACHSCLXR",XDOLH)
+27 ;
+28 FOR XREF="AC","B","EOBD","EOBP","EOBR","ES","PB","PDOS","TB","VB"
DO CLEAN
+29 ;
+30 IF MOCK
WRITE !!!,"This was a trial run and no actual changes were made",!,"These numbers are counts only"
+31 WRITE !!!,"Number of cross references examined:",?50,+$GET(COUNT("TOTCHK"))
+32 WRITE !!,"Total number of cross references removed:",?50,+$GET(COUNT("KILL"))
+33 WRITE !
+34 FOR XREF="AC","B","EOBD","EOBP","EOBR","ES","PB","PDOS","TB","VB"
WRITE !,"For cross reference ",XREF,":",?50,+$GET(COUNT(XREF))
+35 WRITE !!
+36 SET ^TEMP("ACHSCLXR",DOLH)=$HOROLOG
+37 ;
+38 KILL COUNT,DOLH,FAC,MOCK,SS1,SS2,SS3,SS4,SS5,XREF,XDOLH
+39 QUIT
+40 ;
CLEAN ;
+1 ;handle AC as a special case, since it appears in the first
+2 ;subscript position
+3 IF XREF="AC"
SET SS1="AC"
DO CLEAN2
QUIT
+4 SET SS1=0
FOR
SET SS1=$ORDER(^ACHSF(SS1))
IF 'SS1
QUIT
DO CLEAN2
+5 QUIT
+6 ;
CLEAN2 ;
+1 IF XREF="B"
SET SS2="D"
DO CLEAN3
QUIT
+2 IF XREF'="AC"
SET SS2=XREF
DO CLEAN3
QUIT
+3 SET SS2=""
FOR
SET SS2=$ORDER(^ACHSF(SS1,SS2))
IF SS2=""
QUIT
DO CLEAN3
+4 QUIT
+5 ;
CLEAN3 ;
+1 IF XREF="B"
SET SS3=XREF
DO CLEAN4
QUIT
+2 SET SS3=""
FOR
SET SS3=$ORDER(^ACHSF(SS1,SS2,SS3))
IF SS3=""
QUIT
DO CLEAN4
+3 QUIT
+4 ;
CLEAN4 ;
+1 ;we can now identify the facility code. It's in subscript 1
+2 ;unless the cross reference is AC, then it's in ss 3.
+3 ;
+4 IF XREF="AC"
SET FAC=SS3
+5 IF '$TEST
SET FAC=SS1
+6 ;
+7 ;for cross reference EOBR, doc pointer is in ss3, so we are
+8 ;ready to test
+9 IF XREF="EOBR"
Begin DoDot:1
+10 SET COUNT("TOTCHK")=$GET(COUNT("TOTCHK"))+1
IF COUNT("TOTCHK")#500=0
WRITE " ."
+11 IF $DATA(^ACHSF(FAC,"D",SS3))
QUIT
+12 MERGE ^TEMP("ACHSCLXR",DOLH,SS1,SS2,SS3)=^ACHSF(SS1,SS2,SS3)
+13 SET COUNT("KILL")=$GET(COUNT("KILL"))+1
+14 SET COUNT(XREF)=$GET(COUNT(XREF))+1
+15 IF MOCK
QUIT
+16 KILL ^ACHSF(SS1,SS2,SS3)
+17 QUIT
End DoDot:1
QUIT
+18 SET SS4=""
FOR
SET SS4=$ORDER(^ACHSF(SS1,SS2,SS3,SS4))
IF SS4=""
QUIT
DO CLEAN5
+19 QUIT
+20 ;
CLEAN5 ;
+1 ;all of the cross references have the doc pointer in ss4, except
+2 ;EOBR, which is already done, and TB and B, which are handled as
+3 ;exceptions
+4 ;
+5 IF XREF'="TB"
IF (XREF'="B")
Begin DoDot:1
+6 SET COUNT("TOTCHK")=$GET(COUNT("TOTCHK"))+1
IF COUNT("TOTCHK")#500=0
WRITE " ."
+7 IF $DATA(^ACHSF(FAC,"D",SS4))
QUIT
+8 MERGE ^TEMP("ACHSCLXR",DOLH,SS1,SS2,SS3,SS4)=^ACHSF(SS1,SS2,SS3,SS4)
+9 SET COUNT("KILL")=$GET(COUNT("KILL"))+1
+10 SET COUNT(XREF)=$GET(COUNT(XREF))+1
+11 IF MOCK
QUIT
+12 KILL ^ACHSF(SS1,SS2,SS3,SS4)
+13 QUIT
End DoDot:1
QUIT
+14 SET SS5=""
FOR
SET SS5=$ORDER(^ACHSF(SS1,SS2,SS3,SS4,SS5))
IF SS5=""
QUIT
DO CLEAN6
+15 QUIT
+16 ;
CLEAN6 ;
+1 SET COUNT("TOTCHK")=$GET(COUNT("TOTCHK"))+1
IF COUNT("TOTCHK")#500=0
WRITE " ."
+2 IF $DATA(^ACHSF(FAC,"D",SS5))
QUIT
+3 MERGE ^TEMP("ACHSCLXR",DOLH,SS1,SS2,SS3,SS4,SS5)=^ACHSF(SS1,SS2,SS3,SS4,SS5)
+4 SET COUNT("KILL")=$GET(COUNT("KILL"))+1
+5 SET COUNT(XREF)=$GET(COUNT(XREF))+1
+6 IF MOCK
QUIT
+7 KILL ^ACHSF(SS1,SS2,SS3,SS4,SS5)
+8 QUIT
