RACPT.m

RACPT ;HISC/GJC AISC/DMK-Procedure/CPT Stats Report ;12/29/00  11:27

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

CHK D CHK^RACPT1 I $G(RAQUIT)!$G(RAPOP) G Q

START ; start processing

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

 S BEGDATE(0)=$E(BEGDATE,4,5)_"/"_$E(BEGDATE,6,7)_"/"_$E(BEGDATE,2,3)

 S ENDDATE(0)=$E(ENDDATE,4,5)_"/"_$E(ENDDATE,6,7)_"/"_$E(ENDDATE,2,3)

 S X="NOW",%DT="T" D ^%DT K %DT D D^RAUTL S RARUNDTE=Y

 S QQ="",$P(QQ,"=",80)="=",X=""

 S RASORT=$S(RASORT="B":"I,O",1:RASORT)

 F I=RABEG-.0001:0 S I=$O(^RADPT("AR",I)) Q:'I!(I>RAEND)  S RADFN="" F  S RADFN=$O(^RADPT("AR",I,RADFN)) Q:RADFN'>0  S RADTI=9999999.9999-I I $D(^RADPT(RADFN,"DT",RADTI,0)) S RAY=^(0) D MORE

DIV K RAIMAG

 F II=1:1 S RAI=$P(RASORT,",",II) Q:RAI=""  S RADIVN(0)="" F  S RADIVN(0)=$O(^TMP($J,"RA D-TYPE",RADIVN(0))) Q:RADIVN(0)=""  S RADIVN=0 F  S RADIVN=$O(^TMP($J,"RA D-TYPE",RADIVN(0),RADIVN)) Q:RADIVN'>0  D

 . S RAIMAG(0)=""

 . F  S RAIMAG(0)=$O(^TMP($J,"RA I-TYPE",RAIMAG(0))) Q:RAIMAG(0)=""  S RAIMAG=0 F  S RAIMAG=$O(^TMP($J,"RA I-TYPE",RAIMAG(0),RAIMAG)) Q:RAIMAG'>0  D

 .. S RAIMAG(1)=$E(RAIMAG(0),1,3)_"-"_RAIMAG

 .. I $O(^TMP($J,"RA",RAI,RADIVN,RAIMAG(1),""))="" S ^TMP($J,"RA",RAI,RADIVN,RAIMAG(1))="" Q  ;un-used Div-Img combin.

 .. S L="" F  S L=$O(^TMP($J,"RA",RAI,RADIVN,RAIMAG(1),L)) Q:L=""  S K="" F  S K=$O(^TMP($J,"RA",RAI,RADIVN,RAIMAG(1),L,K)) Q:K=""  D

 ... S ^TMP($J,"RA",RAI,RADIVN,RAIMAG(1),"COST")=^TMP($J,"RA",RAI,RADIVN,RAIMAG(1),L,K)*$P($G(^RAMIS(71,K,0)),U,10)+$G(^TMP($J,"RA",RAI,RADIVN,RAIMAG(1),"COST"))

 ... Q

 .. Q

 . Q

 S (RADIV,X,RAI)="",RAEXIT=0,PAGE=1

 F II=1:1 S RAI=$P(RASORT,",",II) Q:RAI=""!RAEXIT  D HANG^RACPT1:$$SRTPA^RACPT1(II) Q:RAEXIT  S RADIV="" F  S RADIV=$O(^TMP($J,"RA",RAI,RADIV)) Q:RADIV=""!RAEXIT  D GET

Q ;

 F I="RA","RA D-TYPE","RA I-TYPE","RA P-TYPE" K ^TMP($J,I)

 K BEGDATE,C,ENDDATE,I,II,J,K,L,PAGE,QQ,RABEG,RACAT,RACN,RACNI,CPT,RADFN

 K RADIV,RADIV1,RADIVN,RADTI,RAEND,RAEOPFLG,RAEXIT,RAI,RAIMAG,RAINPUT

 K RAPOP,RAPROC,RAQUIT,RARUNDTE,RASORT,RASW,RATOT,RAUT,RAX,RAY,RASV

 K %DT,DIR,DIROUT,DIRUT,DTOUT,DUOUT,RAMES,RANUMPRC,RAUTIL,X,Y,Z,ZTDESC

 K RACAN,ZTRTN,ZTSAVE,ZTSK,RACMLIST

 K:$D(RAPSTX) RACCESS,RAPSTX

 W ! D CLOSE^RAUTL

 K DDH,POP

 Q

 ; data storage description :

 ; ^tmp($j,"ra","o",499,"gen-1",36200,751)=2 ; two of this proc was done

 ; ^tmp($j,"ra","o",499,"gen-1",71021,59)=5 ; five of this proc was done

 ; ... etc.

 ; ^tmp($j,"ra","o",499,"gen-1","cost")=sum cost all procs this img typ

 ; ^tmp($j,"ra","o",499,"gen-1","done")=sum total no. procs this img typ

MORE ;

 S (RAIMAG,Y)=$P(RAY,U,2),C=$P(^DD(70.02,2,0),U,2) Q:RAIMAG'>0

 D Y^DIQ S RAIMAG(0)=Y,RAIMAG(1)=$E(RAIMAG(0),1,3)_"-"_RAIMAG

 I $D(^TMP($J,"RA I-TYPE",RAIMAG(0),RAIMAG))[0 Q  ;img loc not selected

 S (RADIVN,Y)=$P(RAY,U,3),C=$P(^DD(70.02,3,0),U,2) Q:RADIVN'>0

 D Y^DIQ S RADIVN(0)=Y

 I $D(^TMP($J,"RA D-TYPE",RADIVN(0),RADIVN))[0 Q  ;div not selected

 S RACNI=0 F  S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI  I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S RAX=^(0) D SET

 Q

SET ;

 Q:'RACAN&($P($G(^RA(72,+$P(RAX,"^",3),0)),"^",3)=0)  ; quit if

 ; cancelled exams are not to be included & our exam is indeed cancelled

 S RADIV=$P(RAY,"^",3) Q:RADIV=""

 S (RAPROC,Y)=+$P(RAX,"^",2),C=$P(^DD(70.03,2,0),U,2) Q:RAPROC'>0

 D Y^DIQ S RAPROC(0)=Y

 I $D(^TMP($J,"RA P-TYPE",RAPROC(0),RAPROC))[0,RAINPUT=0 Q  ;proc not sel

 S RACAT=$S($D(^DIC(42,+$P(RAX,"^",6),0)):"I",1:"O")

 Q:RASORT'[RACAT  ;category of in/outpatient status not selected

 S CPT=$S($D(^RAMIS(71,RAPROC,0)):$P(^(0),"^",9),1:"") Q:CPT=""

 D:$G(RACMLIST) CMLIST^RAWKL1(.CPT)

 S ^TMP($J,"RA",RACAT,RADIV,RAIMAG(1),CPT,RAPROC)=$G(^TMP($J,"RA",RACAT,RADIV,RAIMAG(1),CPT,RAPROC))+1

 S ^TMP($J,"RA",RACAT,RADIV,RAIMAG(1),"DONE")=$G(^TMP($J,"RA",RACAT,RADIV,RAIMAG(1),"DONE"))+1

 Q

GET ;

 S RAIMAG(1)="",RAEOPFLG=0

 F  S RAIMAG(1)=$O(^TMP($J,"RA",RAI,RADIV,RAIMAG(1))) Q:RAIMAG(1)=""!RAEXIT  S RATOT(3)=0 D

 . S RAIMAG=+$P(RAIMAG(1),"-",2)

 . S RAIMAG(0)=$P($G(^RA(79.2,RAIMAG,0)),U)

 . I RAIMAG(0)="" S RAIMAG(0)="UNKNOWN"

 . D HED^RACPT1

 . I $O(^TMP($J,"RA",RAI,RADIV,RAIMAG(1),""))="" D  Q

 .. W !!,"No reports entered for the selected time frame."

 .. I ($O(^TMP($J,"RA",RAI,RADIV,RAIMAG(1)))]"")!($O(^TMP($J,"RA",RAI,RADIV))]"")!($O(^TMP($J,"RA",RAI))]"") S RAEOPFLG=1 D HANG^RACPT1

 .. Q

 . S CPT=""

 . F  S CPT=$O(^TMP($J,"RA",RAI,RADIV,RAIMAG(1),CPT)) Q:CPT=""!RAEXIT  S J=0 D

 .. F  S J=$O(^TMP($J,"RA",RAI,RADIV,RAIMAG(1),CPT,J)) Q:J'>0!RAEXIT  S RATOT=^(J) D PRINT^RACPT1 Q:RAEXIT

 .. Q

 . W !?12,"Total for this imaging type -->",?45,$J(^TMP($J,"RA",RAI,RADIV,RAIMAG(1),"DONE"),5),?63,$J(^("COST"),12,2)

 . I ($O(^TMP($J,"RA",RAI,RADIV,RAIMAG(1)))]"")!($O(^TMP($J,"RA",RAI,RADIV))]"") S RAEOPFLG=1 D HANG^RACPT1

 . Q

 Q

RACPT     ;HISC/GJC AISC/DMK-Procedure/CPT Stats Report ;12/29/00  11:27

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

CHK        DO CHK^RACPT1

           IF $GET">GET(RAQUIT)!$GET">GET(RAPOP)

               GOTO Q

START     ; start processing

 +1        USE IO

           KILL ^TMP($JOB,"RA")

 +2        SET BEGDATE(0)=$EXTRACT(BEGDATE,4,5)_"/"_$EXTRACT(BEGDATE,6,7)_"/"_$EXTRACT(BEGDATE,2,3)

 +3        SET ENDDATE(0)=$EXTRACT(ENDDATE,4,5)_"/"_$EXTRACT(ENDDATE,6,7)_"/"_$EXTRACT(ENDDATE,2,3)

 +4        SET X="NOW"

           SET %DT="T"

           DO ^%DT

           KILL %DT

           DO D^RAUTL

           SET RARUNDTE=Y

 +5        SET QQ=""

           SET $PIECE(QQ,"=",80)="="

           SET X=""

 +6        SET RASORT=$SELECT(RASORT="B":"I,O",1:RASORT)

 +7        FOR I=RABEG-.0001:0

               SET I=$ORDER(^RADPT("AR",I))

               IF 'I!(I>RAEND)

                   QUIT 

               SET RADFN=""

               FOR 

                   SET RADFN=$ORDER(^RADPT("AR",I,RADFN))

                   IF RADFN'>0

                       QUIT 

                   SET RADTI=9999999.9999-I

                   IF $DATA(^RADPT(RADFN,"DT",RADTI,0))

                       SET RAY=^(0)

                       DO MORE

DIV        KILL RAIMAG

 +1        FOR II=1:1

               SET RAI=$PIECE(RASORT,",",II)

               IF RAI=""

                   QUIT 

               SET RADIVN(0)=""

               FOR 

                   SET RADIVN(0)=$ORDER(^TMP($JOB,"RA D-TYPE",RADIVN(0)))

                   IF RADIVN(0)=""

                       QUIT 

                   SET RADIVN=0

                   FOR 

                       SET RADIVN=$ORDER(^TMP($JOB,"RA D-TYPE",RADIVN(0),RADIVN))

                       IF RADIVN'>0

                           QUIT 

                       Begin DoDot:1

 +2                        SET RAIMAG(0)=""

 +3                        FOR 

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

                               IF RAIMAG(0)=""

                                   QUIT 

                               SET RAIMAG=0

                               FOR 

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

                                   IF RAIMAG'>0

                                       QUIT 

                                   Begin DoDot:2

 +4                                    SET RAIMAG(1)=$EXTRACT(RAIMAG(0),1,3)_"-"_RAIMAG

 +5       ;un-used Div-Img combin.

                                       IF $ORDER(^TMP($JOB,"RA",RAI,RADIVN,RAIMAG(1),""))=""

                                           SET ^TMP($JOB,"RA",RAI,RADIVN,RAIMAG(1))=""

                                           QUIT 

 +6                                    SET L=""

                                       FOR 

                                           SET L=$ORDER(^TMP($JOB,"RA",RAI,RADIVN,RAIMAG(1),L))

                                           IF L=""

                                               QUIT 

                                           SET K=""

                                           FOR 

                                               SET K=$ORDER(^TMP($JOB,"RA",RAI,RADIVN,RAIMAG(1),L,K))

                                               IF K=""

                                                   QUIT 

                                               Begin DoDot:3

 +7                                                SET ^TMP($JOB,"RA",RAI,RADIVN,RAIMAG(1),"COST")=^TMP($JOB,"RA",RAI,RADIVN,RAIMAG(1),L,K)*$PIECE($GET">GET(^RAMIS(71,K,0)),U,10)+$GET">GET(^TMP($JOB,"RA",RAI,RADIVN,RAIMAG(1),"COST"))

 +8                                                QUIT 

                                               End DoDot:3

 +9                                    QUIT 

                                   End DoDot:2

 +10                       QUIT 

                       End DoDot:1

 +11       SET (RADIV,X,RAI)=""

           SET RAEXIT=0

           SET PAGE=1

 +12       FOR II=1:1

               SET RAI=$PIECE(RASORT,",",II)

               IF RAI=""!RAEXIT

                   QUIT 

               IF $$SRTPA^RACPT1(II)

                   DO HANG^RACPT1

               IF RAEXIT

                   QUIT 

               SET RADIV=""

               FOR 

                   SET RADIV=$ORDER(^TMP($JOB,"RA",RAI,RADIV))

                   IF RADIV=""!RAEXIT

                       QUIT 

                   DO GET

Q         ;

 +1        FOR I="RA","RA D-TYPE","RA I-TYPE","RA P-TYPE"

               KILL ^TMP($JOB,I)

 +2        KILL BEGDATE,C,ENDDATE,I,II,J,K,L,PAGE,QQ,RABEG,RACAT,RACN,RACNI,CPT,RADFN

 +3        KILL RADIV,RADIV1,RADIVN,RADTI,RAEND,RAEOPFLG,RAEXIT,RAI,RAIMAG,RAINPUT

 +4        KILL RAPOP,RAPROC,RAQUIT,RARUNDTE,RASORT,RASW,RATOT,RAUT,RAX,RAY,RASV

 +5        KILL %DT,DIR,DIROUT,DIRUT,DTOUT,DUOUT,RAMES,RANUMPRC,RAUTIL,X,Y,Z,ZTDESC

 +6        KILL RACAN,ZTRTN,ZTSAVE,ZTSK,RACMLIST

 +7        IF $DATA(RAPSTX)

               KILL RACCESS,RAPSTX

 +8        WRITE !

           DO CLOSE^RAUTL

 +9        KILL DDH,POP

 +10       QUIT 

 +11      ; data storage description :

 +12      ; ^tmp($j,"ra","o",499,"gen-1",36200,751)=2 ; two of this proc was done

 +13      ; ^tmp($j,"ra","o",499,"gen-1",71021,59)=5 ; five of this proc was done

 +14      ; ... etc.

 +15      ; ^tmp($j,"ra","o",499,"gen-1","cost")=sum cost all procs this img typ

 +16      ; ^tmp($j,"ra","o",499,"gen-1","done")=sum total no. procs this img typ

MORE      ;

 +1        SET (RAIMAG,Y)=$PIECE(RAY,U,2)

           SET C=$PIECE(^DD(70.02,2,0),U,2)

           IF RAIMAG'>0

               QUIT 

 +2        DO Y^DIQ

           SET RAIMAG(0)=Y

           SET RAIMAG(1)=$EXTRACT(RAIMAG(0),1,3)_"-"_RAIMAG

 +3       ;img loc not selected

           IF $DATA(^TMP($JOB,"RA I-TYPE",RAIMAG(0),RAIMAG))[0

               QUIT 

 +4        SET (RADIVN,Y)=$PIECE(RAY,U,3)

           SET C=$PIECE(^DD(70.02,3,0),U,2)

           IF RADIVN'>0

               QUIT 

 +5        DO Y^DIQ

           SET RADIVN(0)=Y

 +6       ;div not selected

           IF $DATA(^TMP($JOB,"RA D-TYPE",RADIVN(0),RADIVN))[0

               QUIT 

 +7        SET RACNI=0

           FOR 

               SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))

               IF 'RACNI

                   QUIT 

               IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))

                   SET RAX=^(0)

                   DO SET

 +8        QUIT 

SET       ;

 +1       ; quit if

           IF 'RACAN&($PIECE($GET(^RA(72,+$PIECE(RAX,"^",3),0)),"^",3)=0)

               QUIT 

 +2       ; cancelled exams are not to be included & our exam is indeed cancelled

 +3        SET RADIV=$PIECE(RAY,"^",3)

           IF RADIV=""

               QUIT 

 +4        SET (RAPROC,Y)=+$PIECE(RAX,"^",2)

           SET C=$PIECE(^DD(70.03,2,0),U,2)

           IF RAPROC'>0

               QUIT 

 +5        DO Y^DIQ

           SET RAPROC(0)=Y

 +6       ;proc not sel

           IF $DATA(^TMP($JOB,"RA P-TYPE",RAPROC(0),RAPROC))[0

               IF RAINPUT=0

                   QUIT 

 +7        SET RACAT=$SELECT($DATA(^DIC(42,+$PIECE(RAX,"^",6),0)):"I",1:"O")

 +8       ;category of in/outpatient status not selected

           IF RASORT'[RACAT

               QUIT 

 +9        SET CPT=$SELECT($DATA(^RAMIS(71,RAPROC,0)):$PIECE(^(0),"^",9),1:"")

           IF CPT=""

               QUIT 

 +10       IF $GET(RACMLIST)

               DO CMLIST^RAWKL1(.CPT)

 +11       SET ^TMP($JOB,"RA",RACAT,RADIV,RAIMAG(1),CPT,RAPROC)=$GET(^TMP($JOB,"RA",RACAT,RADIV,RAIMAG(1),CPT,RAPROC))+1

 +12       SET ^TMP($JOB,"RA",RACAT,RADIV,RAIMAG(1),"DONE")=$GET(^TMP($JOB,"RA",RACAT,RADIV,RAIMAG(1),"DONE"))+1

 +13       QUIT 

GET       ;

 +1        SET RAIMAG(1)=""

           SET RAEOPFLG=0

 +2        FOR 

               SET RAIMAG(1)=$ORDER(^TMP($JOB,"RA",RAI,RADIV,RAIMAG(1)))

               IF RAIMAG(1)=""!RAEXIT

                   QUIT 

               SET RATOT(3)=0

               Begin DoDot:1

 +3                SET RAIMAG=+$PIECE(RAIMAG(1),"-",2)

 +4                SET RAIMAG(0)=$PIECE($GET(^RA(79.2,RAIMAG,0)),U)

 +5                IF RAIMAG(0)=""

                       SET RAIMAG(0)="UNKNOWN"

 +6                DO HED^RACPT1

 +7                IF $ORDER(^TMP($JOB,"RA",RAI,RADIV,RAIMAG(1),""))=""

                       Begin DoDot:2

 +8                        WRITE !!,"No reports entered for the selected time frame."

 +9                        IF ($ORDER(^TMP($JOB,"RA",RAI,RADIV,RAIMAG(1)))]"")!($ORDER(^TMP($JOB,"RA",RAI,RADIV))]"")!($ORDER(^TMP($JOB,"RA",RAI))]"")

                               SET RAEOPFLG=1

                               DO HANG^RACPT1

 +10                       QUIT 

                       End DoDot:2

                       QUIT 

 +11               SET CPT=""

 +12               FOR 

                       SET CPT=$ORDER(^TMP($JOB,"RA",RAI,RADIV,RAIMAG(1),CPT))

                       IF CPT=""!RAEXIT

                           QUIT 

                       SET J=0

                       Begin DoDot:2

 +13                       FOR 

                               SET J=$ORDER(^TMP($JOB,"RA",RAI,RADIV,RAIMAG(1),CPT,J))

                               IF J'>0!RAEXIT

                                   QUIT 

                               SET RATOT=^(J)

                               DO PRINT^RACPT1

                               IF RAEXIT

                                   QUIT 

 +14                       QUIT 

                       End DoDot:2

 +15               WRITE !?12,"Total for this imaging type -->",?45,$JUSTIFY(^TMP($JOB,"RA",RAI,RADIV,RAIMAG(1),"DONE"),5),?63,$JUSTIFY(^("COST"),12,2)

 +16               IF ($ORDER(^TMP($JOB,"RA",RAI,RADIV,RAIMAG(1)))]"")!($ORDER(^TMP($JOB,"RA",RAI,RADIV))]"")

                       SET RAEOPFLG=1

                       DO HANG^RACPT1

 +17               QUIT 

               End DoDot:1

 +18       QUIT