- 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
