RAPERR.m

RAPERR ;HISC/CAH-Print Rad/NM Procedures with missing/invalid CPT/Stop codes ;8/30/96  11:00

 ;;5.0;Radiology/Nuclear Medicine;**10**;Mar 16, 1998

START W !!!,"This option prints a list of Radiology/Nuclear Medicine Procedures"

 W !,"with missing or invalid CPT's and DSS ID's, and Imaging Locations"

 W !,"pointing to Hospital Locations with inappropriate set-up parameters."

 W !,"Broad, parent and inactive procedures are not required to have codes."

 W !,"To be valid, DSS ID's must be in the Imaging Stop Codes file 71.5;"

 W !,"CPT's must be nationally active.",!!

 K DIR S DIR(0)="Y",DIR("A")="Include Inactive procedures",DIR("B")="NO" D ^DIR I $D(DTOUT)!($D(DUOUT)) D KILL Q

 S RALL=0 I Y=1 S RALL=1

 K ^TMP($J,"RA I-TYPE") S RAXX=$$IMG^RAUTL12()

 I 'RAXX D KILL Q

 S RADT=$S($D(DT)#2:DT,1:$$DT^XLFDT())

 S ZTRTN="EN1^RAPERR",ZTDESC="Rad/Nuc Med Invalid CPT/Stop Report"

 D ZTSAVE,ZIS^RAUTL K ZTRTN,ZTDESC I RAPOP D KILL Q

EN1 ; Start processing

 U IO K ^TMP($J,"RAP")

 S:$D(ZTQUEUED) ZTREQ="@"

 D FIND,PRT,TOTAL,KILL

 Q

FIND S (RAPROC,RAPROCN,RAICTR,RABCTR,RANOCTR,RAISTP,RANOSTP,RAPAGE)=0,U="^"

 S (RANOAMIS,RANODESC)=0

 F  S RAPROCN=$O(^RAMIS(71,"B",RAPROCN)) Q:'$L(RAPROCN)  S RAPROC=0 F  S RAPROC=$O(^RAMIS(71,"B",RAPROCN,RAPROC)) Q:(RAPROC'?1N.N)!($D(RAOUT))  D

 . S RA71(0)=$G(^RAMIS(71,RAPROC,0))

 . S RA71(12)=+$P(RA71(0),"^",12)

 . S RAITYPE=$P($G(^RA(79.2,RA71(12),0)),"^")

 . S:RAITYPE="" RAITYPE="UNKNOWN"

 . Q:'$D(^TMP($J,"RA I-TYPE",RAITYPE,RA71(12)))#2  ; not user selected

 . S RAINA=$G(^RAMIS(71,RAPROC,"I"))

 . I 'RALL,(RAINA),(RAINA'>RADT) Q

 . K RAMSG S RAX=$G(^RAMIS(71,RAPROC,0)) I '$L(RAX) Q

 . I $P(RAX,U,6)="P",('+$O(^RAMIS(71,RAPROC,4,0))) D

 .. S RANODESC=RANODESC+1

 .. S RAMSG(99)="NO descendents entered"

 .. Q

 . I $P(RAX,U,6)]"",("DS"[$P(RAX,U,6)),('+$O(^RAMIS(71,RAPROC,2,0))) D

 .. S RANOAMIS=RANOAMIS+1

 .. S RAMSG(999)="NO AMIS Code(s) entered"

 .. Q

 . S RACPT=$P(RAX,U,9) I 'RACPT,"BP"'[$P(RAX,U,6) S RAMSG(1)="No CPT entered." S RANOCTR=RANOCTR+1

 . I RACPT S X1=$$NAMCODE^RACPTMSC(RACPT,DT) I $P(X1,"^",2)="" S RAMSG(2)="Broken CPT pointer." S RABCTR=RABCTR+1

 . I RACPT,'$$ACTCODE^RACPTMSC(RACPT,DT) S RAMSG(3)="Invalid CPT "_$P(X1,U) S RAICTR=RAICTR+1

 . S RACTR=0 I $O(^RAMIS(71,RAPROC,"STOP",0)),('$$PCE^RAWORK()) D

 .. S RASTP=0 F  S RASTP=$O(^RAMIS(71,RAPROC,"STOP",RASTP)) Q:'RASTP  S X=$G(^RAMIS(71,RAPROC,"STOP",RASTP,0)) I X S RACTR=RACTR+1 D CK700 I '$D(^RAMIS(71.5,"B",+X))!($P(^DIC(40.7,+X,0),U,3)) D BADSTOP

 . I 'RACTR,"BP"'[$P(RAX,U,6),('$$PCE^RAWORK()) S RAMSG(5)="No stop code(s) entered.",RANOSTP=RANOSTP+1

 . I $D(RAMSG) S RAINACT="" S X1=$G(^RAMIS(71,RAPROC,"I")) I X1 S RAMSG("INACT")="*Procedure inactivated on "_$$FMTE^XLFDT(X1,"D")_$S(X1>RADT:" (future inactivation)",1:"")_"*"

 . I $D(RAMSG) D RATYPE S ^TMP($J,"RAP",RAPROCN,RAPROC)=RAMSG("TYPE")_U_$G(RAMSG("INACT")) S X=0 F  S X=$O(RAMSG(X)) Q:'X  S ^TMP($J,"RAP",RAPROCN,RAPROC,X)=RAMSG(X)

 Q

BADSTOP S:'$D(RAMSG(4)) RAMSG(4)="Invalid Stop Code(s): "

 S RAMSG(4)=RAMSG(4)_" "_$P($G(^DIC(40.7,X,0)),U)

 I $P($G(^DIC(40.7,+X,0)),U,3) S RAMSG(4)=RAMSG(4)_" (Inactive)"

 S RAISTP=RAISTP+1

 Q

CK700 ;Check for a 700-level stop code without any other stop code

 I $P($G(^DIC(40.7,+X,0)),U,2)?1"7"2N,$P(^RAMIS(71,RAPROC,"STOP",0),U,4)'>1 S RAMSG(7)="700-series noncredit Stop Code used without any credit Stop Code"

 Q

PRT D HDG

 S (RAPROCN,RAPROC)=0 F  S RAPROCN=$O(^TMP($J,"RAP",RAPROCN)) Q:RAPROCN=""!($D(RAOUT))  S RAPROC=0 F  S RAPROC=$O(^TMP($J,"RAP",RAPROCN,RAPROC)) Q:'RAPROC!($D(RAOUT))  S RAP=^(RAPROC) D

 . W !!,RAPROCN_" "_$P(RAP,U,2) I $L($P(RAP,U,3)) W !?5,$P(RAP,U,3)

 . S RAI=0 F  S RAI=$O(^TMP($J,"RAP",RAPROCN,RAPROC,RAI)) Q:'RAI!($D(RAOUT))  D

 .. W !?5,$G(^TMP($J,"RAP",RAPROCN,RAPROC,RAI))

 .. I $Y>(IOSL-6) D HDG

 . I $D(RAOUT) Q

 Q

HDG I $E(IOST,1,2)="C-",RAPAGE>0 K DIR S DIR(0)="E" W ! D ^DIR I $D(DUOUT)!($D(DTOUT)) S RAOUT=1 Q

 I (RAPAGE>0)!($E(IOST,1,2)="C-") W @IOF

 S RAPAGE=RAPAGE+1

 W ?16,"RADIOLOGY/NUCLEAR MEDICINE INVALID CPT AND STOP CODES"

 W !,"Run Date: ",$$HTE^XLFDT($H),?70,"Page: ",RAPAGE

 I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAOUT=1

 Q

LINE W !

 Q

RATYPE S X2=$P(RAX,U,6),X2=$S(X2="D":"Detailed,",X2="B":"Broad,",X2="S":"Series,",X2="P":"Parent,",1:"Type missing,") S RAMSG("TYPE")=$P(RAX,U,6)_U_"("_X2

 S X2=+$P(RAX,U,12),X2=$G(^RA(79.2,X2,0)),X2=$P(X2,U,3),RAMSG("TYPE")=RAMSG("TYPE")_" "_$S(X2]"":X2,1:"Imaging type missing")_")"

 Q

TOTAL I $D(RAOUT) Q

 I $Y>(IOSL-17) D HDG Q:$D(RAOUT)

 N A,B S A="Imaging Type(s): ",B="" W !!,A

 F  S B=$O(^TMP($J,"RA I-TYPE",B)) Q:B']""  D  Q:$D(RAOUT)

 . I $Y>(IOSL-4) D HDG Q:$D(RAOUT)  W !!,A

 . W:$X>(IOM-($L(B))) !?($X+$L(A)) W B,?($X+3)

 . Q

 W !!,"TOTAL INVALID CPT CODES:  ",RAICTR

 W !,"TOTAL MISSING CPT CODES:  ",RANOCTR

 W !,"TOTAL BROKEN POINTERS TO CPT CODES:  ",RABCTR

 I '$$PCE^RAWORK() W !,"TOTAL INVALID STOP CODES:  ",RAISTP,!,"TOTAL MISSING STOP CODES:  ",RANOSTP

 W !,"TOTAL PARENT PROCEDURES W/O DESCENDENTS:  ",RANODESC

 W !,"TOTAL SERIES AND/OR DETAILED PROCEDURES W/O AMIS CODES:  ",RANOAMIS

 W !!,"Note:  Remember to review the entries in the Imaging Stop Codes file #71.5",!,"every year in October to make sure they agree with VA HQ rules.  If the entries",!,"in file 71.5 are not accurate, this report will not be accurate.",!

 I $$PCE^RAWORK() D ISTOP^RAPERR1

 Q

KILL ; Kill and quit

 D ^%ZISC K ^TMP($J,"RAP"),^TMP($J,"RA I-TYPE")

 K DIR,DIROUT,DIRUT,DTOUT,DUOUT,POP,RA71,RABCTR,RACPT,RACTR,RADT,RAI

 K RAICTR,RAINA,RAINACT,RAISTP,RAITYPE,RALL,RAMES,RAMSG,RANOAMIS,RANOCTR

 K RANODESC,RANOSTP,RAOUT,RAP,RAPAGE,RAPOP,RAPROC,RAPROCN,RASTP,RATYPE

 K RAX,RAXX,X,X1,X2,Y,ZTDESC,ZTRTN,ZTSAVE

 K DISYS,I,RA44,RA791,RAILOC

 Q

ZTSAVE ; Save off variable for the queued process.

 N I F I="RADT","RALL","^TMP($J,""RA I-TYPE""," S ZTSAVE(I)=""

 Q

RAPERR    ;HISC/CAH-Print Rad/NM Procedures with missing/invalid CPT/Stop codes ;8/30/96  11:00

 +1       ;;5.0;Radiology/Nuclear Medicine;**10**;Mar 16, 1998

START      WRITE !!!,"This option prints a list of Radiology/Nuclear Medicine Procedures"

 +1        WRITE !,"with missing or invalid CPT's and DSS ID's, and Imaging Locations"

 +2        WRITE !,"pointing to Hospital Locations with inappropriate set-up parameters."

 +3        WRITE !,"Broad, parent and inactive procedures are not required to have codes."

 +4        WRITE !,"To be valid, DSS ID's must be in the Imaging Stop Codes file 71.5;"

 +5        WRITE !,"CPT's must be nationally active.",!!

 +6        KILL DIR

           SET DIR(0)="Y"

           SET DIR("A")="Include Inactive procedures"

           SET DIR("B")="NO"

           DO ^DIR

           IF $DATA(DTOUT)!($DATA(DUOUT))

               DO KILL

               QUIT 

 +7        SET RALL=0

           IF Y=1

               SET RALL=1

 +8        KILL ^TMP($JOB,"RA I-TYPE")

           SET RAXX=$$IMG^RAUTL12()

 +9        IF 'RAXX

               DO KILL

               QUIT 

 +10       SET RADT=$SELECT($DATA(DT)#2:DT,1:$$DT^XLFDT())

 +11       SET ZTRTN="EN1^RAPERR"

           SET ZTDESC="Rad/Nuc Med Invalid CPT/Stop Report"

 +12       DO ZTSAVE

           DO ZIS^RAUTL

           KILL ZTRTN,ZTDESC

           IF RAPOP

               DO KILL

               QUIT 

EN1       ; Start processing

 +1        USE IO

           KILL ^TMP($JOB,"RAP")

 +2        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +3        DO FIND

           DO PRT

           DO TOTAL

           DO KILL

 +4        QUIT 

FIND       SET (RAPROC,RAPROCN,RAICTR,RABCTR,RANOCTR,RAISTP,RANOSTP,RAPAGE)=0

           SET U="^"

 +1        SET (RANOAMIS,RANODESC)=0

 +2        FOR 

               SET RAPROCN=$ORDER(^RAMIS(71,"B",RAPROCN))

               IF '$LENGTH(RAPROCN)

                   QUIT 

               SET RAPROC=0

               FOR 

                   SET RAPROC=$ORDER(^RAMIS(71,"B",RAPROCN,RAPROC))

                   IF (RAPROC'?1N.N)!($DATA(RAOUT))

                       QUIT 

                   Begin DoDot:1

 +3                    SET RA71(0)=$GET(^RAMIS(71,RAPROC,0))

 +4                    SET RA71(12)=+$PIECE(RA71(0),"^",12)

 +5                    SET RAITYPE=$PIECE($GET(^RA(79.2,RA71(12),0)),"^")

 +6                    IF RAITYPE=""

                           SET RAITYPE="UNKNOWN"

 +7       ; not user selected

                       IF '$DATA(^TMP($JOB,"RA I-TYPE",RAITYPE,RA71(12)))#2

                           QUIT 

 +8                    SET RAINA=$GET(^RAMIS(71,RAPROC,"I"))

 +9                    IF 'RALL

                           IF (RAINA)

                               IF (RAINA'>RADT)

                                   QUIT 

 +10                   KILL RAMSG

                       SET RAX=$GET(^RAMIS(71,RAPROC,0))

                       IF '$LENGTH(RAX)

                           QUIT 

 +11                   IF $PIECE(RAX,U,6)="P"

                           IF ('+$ORDER(^RAMIS(71,RAPROC,4,0)))

                               Begin DoDot:2

 +12                               SET RANODESC=RANODESC+1

 +13                               SET RAMSG(99)="NO descendents entered"

 +14                               QUIT 

                               End DoDot:2

 +15                   IF $PIECE(RAX,U,6)]""

                           IF ("DS"[$PIECE(RAX,U,6))

                               IF ('+$ORDER(^RAMIS(71,RAPROC,2,0)))

                                   Begin DoDot:2

 +16                                   SET RANOAMIS=RANOAMIS+1

 +17                                   SET RAMSG(999)="NO AMIS Code(s) entered"

 +18                                   QUIT 

                                   End DoDot:2

 +19                   SET RACPT=$PIECE(RAX,U,9)

                       IF 'RACPT

                           IF "BP"'[$PIECE(RAX,U,6)

                               SET RAMSG(1)="No CPT entered."

                               SET RANOCTR=RANOCTR+1

 +20                   IF RACPT

                           SET X1=$$NAMCODE^RACPTMSC(RACPT,DT)

                           IF $PIECE(X1,"^",2)=""

                               SET RAMSG(2)="Broken CPT pointer."

                               SET RABCTR=RABCTR+1

 +21                   IF RACPT

                           IF '$$ACTCODE^RACPTMSC(RACPT,DT)

                               SET RAMSG(3)="Invalid CPT "_$PIECE(X1,U)

                               SET RAICTR=RAICTR+1

 +22                   SET RACTR=0

                       IF $ORDER(^RAMIS(71,RAPROC,"STOP",0))

                           IF ('$$PCE^RAWORK())

                               Begin DoDot:2

 +23                               SET RASTP=0

                                   FOR 

                                       SET RASTP=$ORDER(^RAMIS(71,RAPROC,"STOP",RASTP))

                                       IF 'RASTP

                                           QUIT 

                                       SET X=$GET(^RAMIS(71,RAPROC,"STOP",RASTP,0))

                                       IF X

                                           SET RACTR=RACTR+1

                                           DO CK700

                                           IF '$DATA(^RAMIS(71.5,"B",+X))!($PIECE(^DIC(40.7,+X,0),U,3))

                                               DO BADSTOP

                               End DoDot:2

 +24                   IF 'RACTR

                           IF "BP"'[$PIECE(RAX,U,6)

                               IF ('$$PCE^RAWORK())

                                   SET RAMSG(5)="No stop code(s) entered."

                                   SET RANOSTP=RANOSTP+1

 +25                   IF $DATA(RAMSG)

                           SET RAINACT=""

                           SET X1=$GET(^RAMIS(71,RAPROC,"I"))

                           IF X1

                               SET RAMSG("INACT")="*Procedure inactivated on "_$$FMTE^XLFDT(X1,"D")_$SELECT(X1>RADT:" (future inactivation)",1:"")_"*"

 +26                   IF $DATA(RAMSG)

                           DO RATYPE

                           SET ^TMP($JOB,"RAP",RAPROCN,RAPROC)=RAMSG("TYPE")_U_$GET(RAMSG("INACT"))

                           SET X=0

                           FOR 

                               SET X=$ORDER(RAMSG(X))

                               IF 'X

                                   QUIT 

                               SET ^TMP($JOB,"RAP",RAPROCN,RAPROC,X)=RAMSG(X)

                   End DoDot:1

 +27       QUIT 

BADSTOP    IF '$DATA(RAMSG(4))

               SET RAMSG(4)="Invalid Stop Code(s): "

 +1        SET RAMSG(4)=RAMSG(4)_" "_$PIECE($GET(^DIC(40.7,X,0)),U)

 +2        IF $PIECE($GET(^DIC(40.7,+X,0)),U,3)

               SET RAMSG(4)=RAMSG(4)_" (Inactive)"

 +3        SET RAISTP=RAISTP+1

 +4        QUIT 

CK700     ;Check for a 700-level stop code without any other stop code

 +1        IF $PIECE($GET(^DIC(40.7,+X,0)),U,2)?1"7"2N

               IF $PIECE(^RAMIS(71,RAPROC,"STOP",0),U,4)'>1

                   SET RAMSG(7)="700-series noncredit Stop Code used without any credit Stop Code"

 +2        QUIT 

PRT        DO HDG

 +1        SET (RAPROCN,RAPROC)=0

           FOR 

               SET RAPROCN=$ORDER(^TMP($JOB,"RAP",RAPROCN))

               IF RAPROCN=""!($DATA(RAOUT))

                   QUIT 

               SET RAPROC=0

               FOR 

                   SET RAPROC=$ORDER(^TMP($JOB,"RAP",RAPROCN,RAPROC))

                   IF 'RAPROC!($DATA(RAOUT))

                       QUIT 

                   SET RAP=^(RAPROC)

                   Begin DoDot:1

 +2                    WRITE !!,RAPROCN_" "_$PIECE(RAP,U,2)

                       IF $LENGTH($PIECE(RAP,U,3))

                           WRITE !?5,$PIECE(RAP,U,3)

 +3                    SET RAI=0

                       FOR 

                           SET RAI=$ORDER(^TMP($JOB,"RAP",RAPROCN,RAPROC,RAI))

                           IF 'RAI!($DATA(RAOUT))

                               QUIT 

                           Begin DoDot:2

 +4                            WRITE !?5,$GET(^TMP($JOB,"RAP",RAPROCN,RAPROC,RAI))

 +5                            IF $Y>(IOSL-6)

                                   DO HDG

                           End DoDot:2

 +6                    IF $DATA(RAOUT)

                           QUIT 

                   End DoDot:1

 +7        QUIT 

HDG        IF $EXTRACT(IOST,1,2)="C-"

               IF RAPAGE>0

                   KILL DIR

                   SET DIR(0)="E"

                   WRITE !

                   DO ^DIR

                   IF $DATA(DUOUT)!($DATA(DTOUT))

                       SET RAOUT=1

                       QUIT 

 +1        IF (RAPAGE>0)!($EXTRACT(IOST,1,2)="C-")

               WRITE @IOF

 +2        SET RAPAGE=RAPAGE+1

 +3        WRITE ?16,"RADIOLOGY/NUCLEAR MEDICINE INVALID CPT AND STOP CODES"

 +4        WRITE !,"Run Date: ",$$HTE^XLFDT($HOROLOG),?70,"Page: ",RAPAGE

 +5        IF $DATA(ZTQUEUED)

               DO STOPCHK^RAUTL9

               IF $GET(ZTSTOP)=1

                   SET RAOUT=1

 +6        QUIT 

LINE       WRITE !

 +1        QUIT 

RATYPE     SET X2=$PIECE(RAX,U,6)

           SET X2=$SELECT(X2="D":"Detailed,",X2="B":"Broad,",X2="S":"Series,",X2="P":"Parent,",1:"Type missing,")

           SET RAMSG("TYPE")=$PIECE(RAX,U,6)_U_"("_X2

 +1        SET X2=+$PIECE(RAX,U,12)

           SET X2=$GET(^RA(79.2,X2,0))

           SET X2=$PIECE(X2,U,3)

           SET RAMSG("TYPE")=RAMSG("TYPE")_" "_$SELECT(X2]"":X2,1:"Imaging type missing")_")"

 +2        QUIT 

TOTAL      IF $DATA(RAOUT)

               QUIT 

 +1        IF $Y>(IOSL-17)

               DO HDG

               IF $DATA(RAOUT)

                   QUIT 

 +2        NEW A,B

           SET A="Imaging Type(s): "

           SET B=""

           WRITE !!,A

 +3        FOR 

               SET B=$ORDER(^TMP($JOB,"RA I-TYPE",B))

               IF B']""

                   QUIT 

               Begin DoDot:1

 +4                IF $Y>(IOSL-4)

                       DO HDG

                       IF $DATA(RAOUT)

                           QUIT 

                       WRITE !!,A

 +5                IF $X>(IOM-($LENGTH(B)))

                       WRITE !?($X+$LENGTH(A))

                   WRITE B,?($X+3)

 +6                QUIT 

               End DoDot:1

               IF $DATA(RAOUT)

                   QUIT 

 +7        WRITE !!,"TOTAL INVALID CPT CODES:  ",RAICTR

 +8        WRITE !,"TOTAL MISSING CPT CODES:  ",RANOCTR

 +9        WRITE !,"TOTAL BROKEN POINTERS TO CPT CODES:  ",RABCTR

 +10       IF '$$PCE^RAWORK()

               WRITE !,"TOTAL INVALID STOP CODES:  ",RAISTP,!,"TOTAL MISSING STOP CODES:  ",RANOSTP

 +11       WRITE !,"TOTAL PARENT PROCEDURES W/O DESCENDENTS:  ",RANODESC

 +12       WRITE !,"TOTAL SERIES AND/OR DETAILED PROCEDURES W/O AMIS CODES:  ",RANOAMIS

 +13       WRITE !!,"Note:  Remember to review the entries in the Imaging Stop Codes file #71.5",!,"every year in October to make sure they agree with VA HQ rules.  If the entries",!,"in file 71.5 are not accurate, this report will not be accurate.",!

 +14       IF $$PCE^RAWORK()

               DO ISTOP^RAPERR1

 +15       QUIT 

KILL      ; Kill and quit

 +1        DO ^%ZISC

           KILL ^TMP($JOB,"RAP"),^TMP($JOB,"RA I-TYPE")

 +2        KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT,POP,RA71,RABCTR,RACPT,RACTR,RADT,RAI

 +3        KILL RAICTR,RAINA,RAINACT,RAISTP,RAITYPE,RALL,RAMES,RAMSG,RANOAMIS,RANOCTR

 +4        KILL RANODESC,RANOSTP,RAOUT,RAP,RAPAGE,RAPOP,RAPROC,RAPROCN,RASTP,RATYPE

 +5        KILL RAX,RAXX,X,X1,X2,Y,ZTDESC,ZTRTN,ZTSAVE

 +6        KILL DISYS,I,RA44,RA791,RAILOC

 +7        QUIT 

ZTSAVE    ; Save off variable for the queued process.

 +1        NEW I

           FOR I="RADT","RALL","^TMP($J,""RA I-TYPE"","

               SET ZTSAVE(I)=""

 +2        QUIT