ACHSCPTX.m

ACHSCPTX ;IHS/ITSC/PMF - FIX CPT DANGLING X-REF;JUL 10, 2008

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,14**;JUN 11,2001

 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Non-supported Kernel node.

 ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES

 ;FOLLOWING CODE FROM DENNIS AT BILLINGS

AZBADCPT ; ;[ 02/07/2001  11:31 AM ]

 ;Loop through the CPT file to look for non-DINUM'ed entries.

 D ^%ZIS

 U IO

 W !,$P($G(^DIC(4,DUZ(2),0)),U),!!

 S ICPTNODE=0

 F  S ICPTNODE=$O(^ICPT(ICPTNODE)) Q:'ICPTNODE  D

 .I ICPTNODE<100000 D

 ..;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES

 ..;S X=$P($G(^ICPT(ICPTNODE,0)),U)

 ..S X=$P($$CPT^ICPTCOD(ICPTNODE),U,2)

 ..S Y=ICPTNODE

 ..I $L(Y)=1 S Y="0000"_Y

 ..I $L(Y)=2 S Y="000"_Y

 ..I $L(Y)=3 S Y="00"_Y

 ..I $L(Y)=4 S Y="0"_Y

 ..;3.1*14 12.19.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES

 ..;I X'=Y W !,"Node is: ",ICPTNODE,"    Code should be: ",Y,!,^ICPT(ICPTNODE,0),! S ^ACHSCPTX(ICPTNODE)="",ACHSCPTX("GOOD CODE?",ICPTNODE,Y)=""

 ..I X'=Y W !,"Node is: ",ICPTNODE,"    Code should be: ",Y,!,$P($$CPT^ICPTCOD(ICPTNODE),U,2),! S ^ACHSCPTX(ICPTNODE)="",ACHSCPTX("GOOD CODE?",ICPTNODE,Y)=""

 .I ICPTNODE>100000 D

 ..;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES

 ..;S X=$P($G(^ICPT(ICPTNODE,0)),U)

 ..S X=$P($$CPT^ICPTCOD(ICPTNODE),U,2)

 ..S X=$A($E(X,1))_$E(X,2,99)

 ..I X'=ICPTNODE D

 ...W !,"Node is: ",ICPTNODE

 ...;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 6 LINES

 ...;I $E(ICPTNODE,1,2)<43 W "    No Code should be here",!,$G(^ICPT(ICPTNODE,0)),! S ^ACHSCPTX(ICPTNODE)="" Q

 ...I $E(ICPTNODE,1,2)<43 W "    No Code should be here",!,$P($$CPT^ICPTCOD(ICPTNODE),U,2),! S ^ACHSCPTX(ICPTNODE)="" Q

 ...;I $E(ICPTNODE,1,2)>96 W "    No Code should be here",!,$G(^ICPT(ICPTNODE,0)),! S ^ACHSCPTX(ICPTNODE)="" Q

 ...I $E(ICPTNODE,1,2)>96 W "    No Code should be here",!,$P($$CPT^ICPTCOD(ICPTNODE),U,2),! S ^ACHSCPTX(ICPTNODE)="" Q

 ...;W "    Code should be ",$C($E(ICPTNODE,1,2))_$E(ICPTNODE,3,6),!,$G(^ICPT(ICPTNODE,0)),! S ^ACHSCPTX("GOOD CODE?",ICPTNODE,$C($E(ICPTNODE,1,2))_$E(ICPTNODE,3,6))=""

 ...W "    Code should be ",$C($E(ICPTNODE,1,2))_$E(ICPTNODE,3,6),!,$P($$CPT^ICPTCOD(ICPTNODE),U,2),! S ^ACHSCPTX("GOOD CODE?",ICPTNODE,$C($E(ICPTNODE,1,2))_$E(ICPTNODE,3,6))=""

 ;X ^%ZIS("C");IHS/SET/GTH ACHS*3.1*5 12/06/2002

 D ^%ZISC ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 ;D CHSFAC

 Q

 ;

 ;

 ;GO THROUGH 'CHS FACILITY' FILE AND PULL CPT POINTERS

CHSFAC ;

 S U="^"

 S (MAYBECNT,BADCNT,NPTFOUND,FOUND,CPTCNT,UNKNOWN)=0

 S FACILITY=0

 F  S FACILITY=$O(^ACHSF(FACILITY)) Q:+FACILITY=0  D

 .;

 .S DOCUMENT=0

 .F DOCCNT=1:1 S DOCUMENT=$O(^ACHSF(FACILITY,"D",DOCUMENT)) Q:+DOCUMENT=0  D

 ..;W !,DOCUMENT

 ..S CPTMULT=0

 ..F  S CPTMULT=$O(^ACHSF(FACILITY,"D",DOCUMENT,11,CPTMULT)) Q:+CPTMULT=0  D

 ...S CPTINFO=$G(^ACHSF(FACILITY,"D",DOCUMENT,11,CPTMULT,0))

 ...W !,CPTINFO

 ...Q:CPTINFO=""!(CPTINFO'[("ICPT"))

 ...S CODE=$P($P(CPTINFO,";"),U)

 ...S CPTCNT=CPTCNT+1   ;NUMBER OF CPT ENTRIES IN THE CHS GLOBAL

 ...;

 ...;I $D(^ACHSCPTX(CODE)) S BADCNT=BADCNT+1 W !,"IN BAD CODE FILE ",CODE

 ...;I $D(^ACHSCPTX("GOOD CODE?",CODE)) W !,"POSSIBLE GOOD ENTRY TO BE FOUND ",CODE S MAYBECNT=MAYBECNT+1

 ...;I $L(CODE)=1 S Y="0000"_CODE

 ...;I $L(CODE)=2 S Y="000"_CODE

 ...;I $L(CODE)=3 S Y="00"_CODE

 ...;I $L(CODE)=4 S Y="0"_CODE

 ...;I $D(^ACHSCPTX(CODE)) S BADCNT=BADCNT+1 W !,"IN BAD FILE ",CODE

 ...;I $D(^ACHSCPTX("GOOD CODE?",CODE)) W !,"POSSIBLE GOOD ENTRY TO BE FOUND ",CODE S MAYBECNT=MAYBECNT+1

 ...;S ROOT=U_$P($P(CPTINFO,";",2),U)

 ...;S GLOBAL=ROOT_CODE_",0)"

 ...;

 ;

 ;

 Q

ACHSCPTX  ;IHS/ITSC/PMF - FIX CPT DANGLING X-REF;JUL 10, 2008

 +1       ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,14**;JUN 11,2001

 +2       ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Non-supported Kernel node.

 +3       ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES

 +4       ;FOLLOWING CODE FROM DENNIS AT BILLINGS

AZBADCPT  ; ;[ 02/07/2001  11:31 AM ]

 +1       ;Loop through the CPT file to look for non-DINUM'ed entries.

 +2        DO ^%ZIS

 +3        USE IO

 +4        WRITE !,$PIECE($GET(^DIC(4,DUZ(2),0)),U),!!

 +5        SET ICPTNODE=0

 +6        FOR 

               SET ICPTNODE=$ORDER(^ICPT(ICPTNODE))

               IF 'ICPTNODE

                   QUIT 

               Begin DoDot:1

 +7                IF ICPTNODE<100000

                       Begin DoDot:2

 +8       ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES

 +9       ;S X=$P($G(^ICPT(ICPTNODE,0)),U)

 +10                       SET X=$PIECE($$CPT^ICPTCOD(ICPTNODE),U,2)

 +11                       SET Y=ICPTNODE

 +12                       IF $LENGTH(Y)=1

                               SET Y="0000"_Y

 +13                       IF $LENGTH(Y)=2

                               SET Y="000"_Y

 +14                       IF $LENGTH(Y)=3

                               SET Y="00"_Y

 +15                       IF $LENGTH(Y)=4

                               SET Y="0"_Y

 +16      ;3.1*14 12.19.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES

 +17      ;I X'=Y W !,"Node is: ",ICPTNODE,"    Code should be: ",Y,!,^ICPT(ICPTNODE,0),! S ^ACHSCPTX(ICPTNODE)="",ACHSCPTX("GOOD CODE?",ICPTNODE,Y)=""

 +18                       IF X'=Y

                               WRITE !,"Node is: ",ICPTNODE,"    Code should be: ",Y,!,$PIECE($$CPT^ICPTCOD(ICPTNODE),U,2),!

                               SET ^ACHSCPTX(ICPTNODE)=""

                               SET ACHSCPTX("GOOD CODE?",ICPTNODE,Y)=""

                       End DoDot:2

 +19               IF ICPTNODE>100000

                       Begin DoDot:2

 +20      ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES

 +21      ;S X=$P($G(^ICPT(ICPTNODE,0)),U)

 +22                       SET X=$PIECE($$CPT^ICPTCOD(ICPTNODE),U,2)

 +23                       SET X=$ASCII($EXTRACT(X,1))_$EXTRACT(X,2,99)

 +24                       IF X'=ICPTNODE

                               Begin DoDot:3

 +25                               WRITE !,"Node is: ",ICPTNODE

 +26      ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 6 LINES

 +27      ;I $E(ICPTNODE,1,2)<43 W "    No Code should be here",!,$G(^ICPT(ICPTNODE,0)),! S ^ACHSCPTX(ICPTNODE)="" Q

 +28                               IF $EXTRACT(ICPTNODE,1,2)<43

                                       WRITE "    No Code should be here",!,$PIECE($$CPT^ICPTCOD(ICPTNODE),U,2),!

                                       SET ^ACHSCPTX(ICPTNODE)=""

                                       QUIT 

 +29      ;I $E(ICPTNODE,1,2)>96 W "    No Code should be here",!,$G(^ICPT(ICPTNODE,0)),! S ^ACHSCPTX(ICPTNODE)="" Q

 +30                               IF $EXTRACT(ICPTNODE,1,2)>96

                                       WRITE "    No Code should be here",!,$PIECE($$CPT^ICPTCOD(ICPTNODE),U,2),!

                                       SET ^ACHSCPTX(ICPTNODE)=""

                                       QUIT 

 +31      ;W "    Code should be ",$C($E(ICPTNODE,1,2))_$E(ICPTNODE,3,6),!,$G(^ICPT(ICPTNODE,0)),! S ^ACHSCPTX("GOOD CODE?",ICPTNODE,$C($E(ICPTNODE,1,2))_$E(ICPTNODE,3,6))=""

 +32                               WRITE "    Code should be ",$CHAR($EXTRACT(ICPTNODE,1,2))_$EXTRACT(ICPTNODE,3,6),!,$PIECE($$CPT^ICPTCOD(ICPTNODE),U,2),!

                                   SET ^ACHSCPTX("GOOD CODE?",ICPTNODE,$CHAR($EXTRACT(ICPTNODE,1,2))_$EXTRACT(ICPTNODE,3,6))=""

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +33      ;X ^%ZIS("C");IHS/SET/GTH ACHS*3.1*5 12/06/2002

 +34      ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

           DO ^%ZISC

 +35      ;D CHSFAC

 +36       QUIT 

 +37      ;

 +38      ;

 +39      ;GO THROUGH 'CHS FACILITY' FILE AND PULL CPT POINTERS

CHSFAC    ;

 +1        SET U="^"

 +2        SET (MAYBECNT,BADCNT,NPTFOUND,FOUND,CPTCNT,UNKNOWN)=0

 +3        SET FACILITY=0

 +4        FOR 

               SET FACILITY=$ORDER(^ACHSF(FACILITY))

               IF +FACILITY=0

                   QUIT 

               Begin DoDot:1

 +5       ;

 +6                SET DOCUMENT=0

 +7                FOR DOCCNT=1:1

                       SET DOCUMENT=$ORDER(^ACHSF(FACILITY,"D",DOCUMENT))

                       IF +DOCUMENT=0

                           QUIT 

                       Begin DoDot:2

 +8       ;W !,DOCUMENT

 +9                        SET CPTMULT=0

 +10                       FOR 

                               SET CPTMULT=$ORDER(^ACHSF(FACILITY,"D",DOCUMENT,11,CPTMULT))

                               IF +CPTMULT=0

                                   QUIT 

                               Begin DoDot:3

 +11                               SET CPTINFO=$GET(^ACHSF(FACILITY,"D",DOCUMENT,11,CPTMULT,0))

 +12                               WRITE !,CPTINFO

 +13                               IF CPTINFO=""!(CPTINFO'[("ICPT"))

                                       QUIT 

 +14                               SET CODE=$PIECE($PIECE(CPTINFO,";"),U)

 +15      ;NUMBER OF CPT ENTRIES IN THE CHS GLOBAL

                                   SET CPTCNT=CPTCNT+1

 +16      ;

 +17      ;I $D(^ACHSCPTX(CODE)) S BADCNT=BADCNT+1 W !,"IN BAD CODE FILE ",CODE

 +18      ;I $D(^ACHSCPTX("GOOD CODE?",CODE)) W !,"POSSIBLE GOOD ENTRY TO BE FOUND ",CODE S MAYBECNT=MAYBECNT+1

 +19      ;I $L(CODE)=1 S Y="0000"_CODE

 +20      ;I $L(CODE)=2 S Y="000"_CODE

 +21      ;I $L(CODE)=3 S Y="00"_CODE

 +22      ;I $L(CODE)=4 S Y="0"_CODE

 +23      ;I $D(^ACHSCPTX(CODE)) S BADCNT=BADCNT+1 W !,"IN BAD FILE ",CODE

 +24      ;I $D(^ACHSCPTX("GOOD CODE?",CODE)) W !,"POSSIBLE GOOD ENTRY TO BE FOUND ",CODE S MAYBECNT=MAYBECNT+1

 +25      ;S ROOT=U_$P($P(CPTINFO,";",2),U)

 +26      ;S GLOBAL=ROOT_CODE_",0)"

 +27      ;

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +28      ;

 +29      ;

 +30       QUIT