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
