RAWKL1.m

RAWKL1 ;HISC/FPT-Workload Reports (cont.) ;12/27/00  11:28

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

RADFN ; count & store in tmp global

 S RADFN=0 F  K RAOR,RAPORT S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:RADFN'>0!($D(RAEOS))  I $D(^RADPT(RADFN,"DT",RADTI,0)) S RAD0=^(0) D RACNI

 Q

RACNI ;

 S RADIV=$P($G(^RA(79,+$P(RAD0,U,3),0)),U),RADIV=$S($D(^DIC(4,+RADIV,0)):+RADIV,1:99)

 Q:'$D(^TMP($J,"RA",RADIV))  S RACNI=0

 ;RAPRIM=0 means want both primary and secondary staff/resid

 F  S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0!($D(RAEOS))  I $D(^(RACNI,0)) S RAP0=^(0),RAPIFN=+$P(RAP0,"^",2) I $D(RACRT(+$P(RAP0,U,3))) D ITNAME I RAITYPE?3AP1"-".N D

 . D CHK:RAPCE,TC:'RAPCE

 . D:RAPCE=12&($G(RAPRIM)=0) SECRES

 . D:RAPCE=15&($G(RAPRIM)=0) SECSTF

 . Q

 Q

CHK ;

 Q:'$D(^TMP($J,"RA",RADIV,RAITYPE))

 K RAFLD("DESC")

 S:RAPCE RAFLD=$S($D(@("^"_RAFILE_"+$P(RAP0,""^"",RAPCE),0)")):$P(^(0),"^"),1:"UNKNOWN") I RAPCE=18,$D(^(0)) S RAFLD("DESC")=" - "_$P(^(0),"^",2)

 I RAINPUT=0,'$D(^TMP($J,"RAFLD",RAFLD)) Q

 I $D(RAFLD("DESC")) S RAFLD=RAFLD_RAFLD("DESC") K RAFLD("DESC")

 S RAFLD=$E(RAFLD,1,30)

 S C=$S($D(^DIC(42,+$P(RAP0,"^",6),0)):"IN",1:"OUT")

 ; for each proc mod, check for Amis Credit Indicator, file 71.2:

 ; where "b"=bilateral, "o"=operating room, "p"=portable

 S I=0 F  S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",I)) Q:I'>0  I $D(^(I,0)) S RAQI=+^(0) D EXTRA^RAUTL12(RAQI)

 Q:'$D(^RAMIS(71,RAPIFN,0))  S RAPRI=^(0)

 ;raz=^ramis(71,rapifn,2,i,0)

 ;ramj=^ramis(71.1,+raz,0)

 S RAPRC=$$LJ^XLFSTR($E($P(RAPRI,"^"),1,27),29," ") D CPT^RAFLM D CMLIST(.RAPRC) Q:'$D(^RAMIS(71,RAPIFN,2))  S I=0 F  S I=$O(^RAMIS(71,RAPIFN,2,I)) Q:I'>0  I $D(^(I,0)) S RAZ=^(0),RAMJ=$S($D(^RAMIS(71.1,+RAZ,0)):^(0),1:"") D PRC

 Q:'$D(RAMIS(1))

 I J=1 S RAMIS=RAMIS(1),RAWT=RAWT(1),RAMUL=RAMUL(1),RAWT=RAWT*RAMUL,RANUM=RAMUL

 I J>1 S RANUM=1,RAWT=0,RAMIS=RAMIS(1) F J=1:1 Q:'$D(RAMIS(J))  S I=RAWT(J),RAMUL=RAMUL(J),RAWT=RAWT+(RAMUL*I)

 D STORE K RAMIS,RAWT,RAMUL,RAZ,RAMJ,RAMULP,RAMULPFL,RAOR,RAPORT

 Q

 ;

STORE ; Store off into ^TMP($J,"RA"

 I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAEOS="" Q:$D(RAEOS)

 ; presence of:

 ; RAOR = operating room, set from extra^rautl12(-) and/or PRC

 ; RAPORT = portable, set from extra^rautl12(-) and/or PRC

 ; RAMULP = proc has >1 Amis Codes

 I $D(RAOR) S A=25 D AUX

 I $D(RAPORT) S A=26 D AUX

 I $D(RAMULP) S A="MULP" D AUX

 S X=^TMP($J,"RA",RADIV),^(RADIV)=($S(C="IN":$P(X,"^")+RANUM,1:$P(X,"^")))_"^"_($S(C="OUT":$P(X,"^",2)+RANUM,1:$P(X,"^",2)))_"^"_($P(X,"^",3)+RAWT)

 S X=^TMP($J,"RA",RADIV,RAITYPE),^(RAITYPE)=($S(C="IN":$P(X,"^")+RANUM,1:$P(X,"^")))_"^"_($S(C="OUT":$P(X,"^",2)+RANUM,1:$P(X,"^",2)))_"^"_($P(X,"^",3)+RAWT)

 S:'($D(^TMP($J,"RA",RADIV,RAITYPE,RAFLD))#2) ^(RAFLD)="0^0^0" S X=^(RAFLD),^(RAFLD)=($S(C="IN":$P(X,"^")+RANUM,1:$P(X,"^")))_"^"_($S(C="OUT":$P(X,"^",2)+RANUM,1:$P(X,"^",2)))_"^"_($P(X,"^",3)+RAWT)

 S:'$D(^TMP($J,"RA",RADIV,RAITYPE,RAFLD,RAMIS,RAPRC)) ^(RAPRC)="0^0^0" S X=^(RAPRC),^(RAPRC)=($S(C="IN":$P(X,"^")+RANUM,1:$P(X,"^")))_"^"_($S(C="OUT":$P(X,"^",2)+RANUM,1:$P(X,"^",2)))_"^"_($P(X,"^",3)+RAWT)

 Q

 ; this PRC is done for each Proc's Amis Code sub record

 ; 1st sub rec would be RAMIS(1), 2nd would be RAMIS(2), etc.

 ; ramis(j)=ien 71.1

 ; rawt(j)=record 71.1's WEIGHT

 ; ramul(j)=file 71'S Amis code sub rec's Amis Weight Multiplier

 ;

PRC I +RAZ=25 S RAOR="" Q

 I +RAZ=26 S RAPORT="" Q

 S:$P(RAZ,"^",3)="Y" RABILAT="" F J=1:1 I '$D(RAMIS(J)) S RAMIS(J)=$S(RAMJ]"":+RAZ,1:99),RAWT(J)=+$P(RAMJ,"^",2),RAMUL(J)=$S(+$P(RAZ,"^",2)>0:+$P(RAZ,U,2),1:1) S:$D(RABILAT)&(RAMUL(J)<2) RAMUL(J)=RAMUL(J)*2 S:J>1 RAMULP="" Q

 K RABILAT

 Q

 ;

AUX S:'$D(^TMP($J,"RA",RADIV,RAITYPE,RAFLD,A,RAPRC)) ^(RAPRC)="0^0^0" S X=^(RAPRC),^(RAPRC)=($S(C="IN":$P(X,"^")+RANUM,1:$P(X,"^")))_"^"_($S(C="OUT":$P(X,"^",2)+RANUM,1:$P(X,"^",2)))_"^"_($P(X,"^",3)+RAWT)

 Q

 ;

TC S RATCI=0 F  S RATCI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",RATCI)) Q:RATCI'>0  S RAFLD=$S($D(^VA(200,+^(RATCI,0),0)):$P(^(0),"^"),1:"") D:RAFLD]"" CHK

 Q

SECRES ; count secondary residents

 Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",0))

 S RASRR=0,RAPCE(1)=RAPCE,RAPCE="SRR"

 F  S RASRR=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",RASRR)) Q:RASRR'>0  S RAFLD=$S($D(^VA(200,+^(RASRR,0),0)):$P(^(0),"^",1),1:"") D:RAFLD]"" CHK

 K RASRR S RAPCE=RAPCE(1)

 Q

SECSTF ; count secondary staff

 Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",0))

 S RASSR=0,RAPCE(1)=RAPCE,RAPCE="SSR"

 F  S RASSR=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",RASSR)) Q:RASSR'>0  S RAFLD=$S($D(^VA(200,+^(RASSR,0),0)):$P(^(0),"^",1),1:"") D:RAFLD]"" CHK

 K RASSR S RAPCE=RAPCE(1)

 Q

 ;

ITNAME ; get imaging type name from Exam's exam status

 S RAITNUM=$P($G(^RA(72,+$P(RAP0,U,3),0)),U,7)

 S RAITYPE=$E($P($G(^RA(79.2,+RAITNUM,0)),U,1),1,3)_"-"_+RAITNUM

 K RAITNUM

 Q

CMLIST(RASTR) ;append max 3 CPTmods onto string and within any ()

 Q:'$G(RACMLIST)  ;user doesn't want CPT mods as separate line items

 Q:'$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",0))

 N RACMSTR,I,J,X

 S I=0 ;put into array to let M sort external values of CPT Mods

 F  S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",I)) Q:I'>0  S X=$$BASICMOD^RACPTMSC(+$G(^(I,0)),DT),RACMSTR($P(X,U,2))=""

 S I="",J=0

 F  S I=$O(RACMSTR(I)) Q:I=""  S J=J+1 Q:J>3  S RACMSTR=$G(RACMSTR)_$S($G(RACMSTR)="":"",1:",")_I

 S:J>3 RACMSTR=RACMSTR_"*"

 S:RASTR["(" RASTR=$E(RASTR,1,($L(RASTR)-1)) ;remove ")"

 S RASTR=RASTR_"-"_RACMSTR_$S(RASTR["(":")",1:"") ;append CPTmods to str

 Q

RAWKL1    ;HISC/FPT-Workload Reports (cont.) ;12/27/00  11:28

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

RADFN     ; count & store in tmp global

 +1        SET RADFN=0

           FOR 

               KILL RAOR,RAPORT

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

               IF RADFN'>0!($DATA(RAEOS))

                   QUIT 

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

                   SET RAD0=^(0)

                   DO RACNI

 +2        QUIT 

RACNI     ;

 +1        SET RADIV=$PIECE($GET(^RA(79,+$PIECE(RAD0,U,3),0)),U)

           SET RADIV=$SELECT($DATA(^DIC(4,+RADIV,0)):+RADIV,1:99)

 +2        IF '$DATA(^TMP($JOB,"RA",RADIV))

               QUIT 

           SET RACNI=0

 +3       ;RAPRIM=0 means want both primary and secondary staff/resid

 +4        FOR 

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

               IF RACNI'>0!($DATA(RAEOS))

                   QUIT 

               IF $DATA(^(RACNI,0))

                   SET RAP0=^(0)

                   SET RAPIFN=+$PIECE(RAP0,"^",2)

                   IF $DATA(RACRT(+$PIECE(RAP0,U,3)))

                       DO ITNAME

                       IF RAITYPE?3AP1"-".N

                           Begin DoDot:1

 +5                            IF RAPCE

                                   DO CHK

                               IF 'RAPCE

                                   DO TC

 +6                            IF RAPCE=12&($GET(RAPRIM)=0)

                                   DO SECRES

 +7                            IF RAPCE=15&($GET(RAPRIM)=0)

                                   DO SECSTF

 +8                            QUIT 

                           End DoDot:1

 +9        QUIT 

CHK       ;

 +1        IF '$DATA(^TMP($JOB,"RA",RADIV,RAITYPE))

               QUIT 

 +2        KILL RAFLD("DESC")

 +3        IF RAPCE

               SET RAFLD=$SELECT($DATA(@("^"_RAFILE_"+$P(RAP0,""^"",RAPCE),0)")):$PIECE(^(0),"^"),1:"UNKNOWN")

           IF RAPCE=18

               IF $DATA(^(0))

                   SET RAFLD("DESC")=" - "_$PIECE(^(0),"^",2)

 +4        IF RAINPUT=0

               IF '$DATA(^TMP($JOB,"RAFLD",RAFLD))

                   QUIT 

 +5        IF $DATA(RAFLD("DESC"))

               SET RAFLD=RAFLD_RAFLD("DESC")

               KILL RAFLD("DESC")

 +6        SET RAFLD=$EXTRACT(RAFLD,1,30)

 +7        SET C=$SELECT($DATA(^DIC(42,+$PIECE(RAP0,"^",6),0)):"IN",1:"OUT")

 +8       ; for each proc mod, check for Amis Credit Indicator, file 71.2:

 +9       ; where "b"=bilateral, "o"=operating room, "p"=portable

 +10       SET I=0

           FOR 

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

               IF I'>0

                   QUIT 

               IF $DATA(^(I,0))

                   SET RAQI=+^(0)

                   DO EXTRA^RAUTL12(RAQI)

 +11       IF '$DATA(^RAMIS(71,RAPIFN,0))

               QUIT 

           SET RAPRI=^(0)

 +12      ;raz=^ramis(71,rapifn,2,i,0)

 +13      ;ramj=^ramis(71.1,+raz,0)

 +14       SET RAPRC=$$LJ^XLFSTR($EXTRACT($PIECE(RAPRI,"^"),1,27),29," ")

           DO CPT^RAFLM

           DO CMLIST(.RAPRC)

           IF '$DATA(^RAMIS(71,RAPIFN,2))

               QUIT 

           SET I=0

           FOR 

               SET I=$ORDER(^RAMIS(71,RAPIFN,2,I))

               IF I'>0

                   QUIT 

               IF $DATA(^(I,0))

                   SET RAZ=^(0)

                   SET RAMJ=$SELECT($DATA(^RAMIS(71.1,+RAZ,0)):^(0),1:"")

                   DO PRC

 +15       IF '$DATA(RAMIS(1))

               QUIT 

 +16       IF J=1

               SET RAMIS=RAMIS(1)

               SET RAWT=RAWT(1)

               SET RAMUL=RAMUL(1)

               SET RAWT=RAWT*RAMUL

               SET RANUM=RAMUL

 +17       IF J>1

               SET RANUM=1

               SET RAWT=0

               SET RAMIS=RAMIS(1)

               FOR J=1:1

                   IF '$DATA(RAMIS(J))

                       QUIT 

                   SET I=RAWT(J)

                   SET RAMUL=RAMUL(J)

                   SET RAWT=RAWT+(RAMUL*I)

 +18       DO STORE

           KILL RAMIS,RAWT,RAMUL,RAZ,RAMJ,RAMULP,RAMULPFL,RAOR,RAPORT

 +19       QUIT 

 +20      ;

STORE     ; Store off into ^TMP($J,"RA"

 +1        IF $DATA(ZTQUEUED)

               DO STOPCHK^RAUTL9

               IF $GET(ZTSTOP)=1

                   SET RAEOS=""

               IF $DATA(RAEOS)

                   QUIT 

 +2       ; presence of:

 +3       ; RAOR = operating room, set from extra^rautl12(-) and/or PRC

 +4       ; RAPORT = portable, set from extra^rautl12(-) and/or PRC

 +5       ; RAMULP = proc has >1 Amis Codes

 +6        IF $DATA(RAOR)

               SET A=25

               DO AUX

 +7        IF $DATA(RAPORT)

               SET A=26

               DO AUX

 +8        IF $DATA(RAMULP)

               SET A="MULP"

               DO AUX

 +9        SET X=^TMP($JOB,"RA",RADIV)

           SET ^(RADIV)=($SELECT(C="IN":$PIECE(X,"^")+RANUM,1:$PIECE(X,"^")))_"^"_($SELECT(C="OUT":$PIECE(X,"^",2)+RANUM,1:$PIECE(X,"^",2)))_"^"_($PIECE(X,"^",3)+RAWT)

 +10       SET X=^TMP($JOB,"RA",RADIV,RAITYPE)

           SET ^(RAITYPE)=($SELECT(C="IN":$PIECE(X,"^")+RANUM,1:$PIECE(X,"^")))_"^"_($SELECT(C="OUT":$PIECE(X,"^",2)+RANUM,1:$PIECE(X,"^",2)))_"^"_($PIECE(X,"^",3)+RAWT)

 +11       IF '($DATA(^TMP($JOB,"RA",RADIV,RAITYPE,RAFLD))#2)

               SET ^(RAFLD)="0^0^0"

           SET X=^(RAFLD)

           SET ^(RAFLD)=($SELECT(C="IN":$PIECE(X,"^")+RANUM,1:$PIECE(X,"^")))_"^"_($SELECT(C="OUT":$PIECE(X,"^",2)+RANUM,1:$PIECE(X,"^",2)))_"^"_($PIECE(X,"^",3)+RAWT)

 +12       IF '$DATA(^TMP($JOB,"RA",RADIV,RAITYPE,RAFLD,RAMIS,RAPRC))

               SET ^(RAPRC)="0^0^0"

           SET X=^(RAPRC)

           SET ^(RAPRC)=($SELECT(C="IN":$PIECE(X,"^")+RANUM,1:$PIECE(X,"^")))_"^"_($SELECT(C="OUT":$PIECE(X,"^",2)+RANUM,1:$PIECE(X,"^",2)))_"^"_($PIECE(X,"^",3)+RAWT)

 +13       QUIT 

 +14      ; this PRC is done for each Proc's Amis Code sub record

 +15      ; 1st sub rec would be RAMIS(1), 2nd would be RAMIS(2), etc.

 +16      ; ramis(j)=ien 71.1

 +17      ; rawt(j)=record 71.1's WEIGHT

 +18      ; ramul(j)=file 71'S Amis code sub rec's Amis Weight Multiplier

 +19      ;

PRC        IF +RAZ=25

               SET RAOR=""

               QUIT 

 +1        IF +RAZ=26

               SET RAPORT=""

               QUIT 

 +2        IF $PIECE(RAZ,"^",3)="Y"

               SET RABILAT=""

           FOR J=1:1

               IF '$DATA(RAMIS(J))

                   SET RAMIS(J)=$SELECT(RAMJ]"":+RAZ,1:99)

                   SET RAWT(J)=+$PIECE(RAMJ,"^",2)

                   SET RAMUL(J)=$SELECT(+$PIECE(RAZ,"^",2)>0:+$PIECE(RAZ,U,2),1:1)

                   IF $DATA(RABILAT)&(RAMUL(J)<2)

                       SET RAMUL(J)=RAMUL(J)*2

                   IF J>1

                       SET RAMULP=""

                   QUIT 

 +3        KILL RABILAT

 +4        QUIT 

 +5       ;

AUX        IF '$DATA(^TMP($JOB,"RA",RADIV,RAITYPE,RAFLD,A,RAPRC))

               SET ^(RAPRC)="0^0^0"

           SET X=^(RAPRC)

           SET ^(RAPRC)=($SELECT(C="IN":$PIECE(X,"^")+RANUM,1:$PIECE(X,"^")))_"^"_($SELECT(C="OUT":$PIECE(X,"^",2)+RANUM,1:$PIECE(X,"^",2)))_"^"_($PIECE(X,"^",3)+RAWT)

 +1        QUIT 

 +2       ;

TC         SET RATCI=0

           FOR 

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

               IF RATCI'>0

                   QUIT 

               SET RAFLD=$SELECT($DATA(^VA(200,+^(RATCI,0),0)):$PIECE(^(0),"^"),1:"")

               IF RAFLD]""

                   DO CHK

 +1        QUIT 

SECRES    ; count secondary residents

 +1        IF '$DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",0))

               QUIT 

 +2        SET RASRR=0

           SET RAPCE(1)=RAPCE

           SET RAPCE="SRR"

 +3        FOR 

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

               IF RASRR'>0

                   QUIT 

               SET RAFLD=$SELECT($DATA(^VA(200,+^(RASRR,0),0)):$PIECE(^(0),"^",1),1:"")

               IF RAFLD]""

                   DO CHK

 +4        KILL RASRR

           SET RAPCE=RAPCE(1)

 +5        QUIT 

SECSTF    ; count secondary staff

 +1        IF '$DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",0))

               QUIT 

 +2        SET RASSR=0

           SET RAPCE(1)=RAPCE

           SET RAPCE="SSR"

 +3        FOR 

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

               IF RASSR'>0

                   QUIT 

               SET RAFLD=$SELECT($DATA(^VA(200,+^(RASSR,0),0)):$PIECE(^(0),"^",1),1:"")

               IF RAFLD]""

                   DO CHK

 +4        KILL RASSR

           SET RAPCE=RAPCE(1)

 +5        QUIT 

 +6       ;

ITNAME    ; get imaging type name from Exam's exam status

 +1        SET RAITNUM=$PIECE($GET(^RA(72,+$PIECE(RAP0,U,3),0)),U,7)

 +2        SET RAITYPE=$EXTRACT($PIECE($GET(^RA(79.2,+RAITNUM,0)),U,1),1,3)_"-"_+RAITNUM

 +3        KILL RAITNUM

 +4        QUIT 

CMLIST(RASTR) ;append max 3 CPTmods onto string and within any ()

 +1       ;user doesn't want CPT mods as separate line items

           IF '$GET(RACMLIST)

               QUIT 

 +2        IF '$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",0))

               QUIT 

 +3        NEW RACMSTR,I,J,X

 +4       ;put into array to let M sort external values of CPT Mods

           SET I=0

 +5        FOR 

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

               IF I'>0

                   QUIT 

               SET X=$$BASICMOD^RACPTMSC(+$GET(^(I,0)),DT)

               SET RACMSTR($PIECE(X,U,2))=""

 +6        SET I=""

           SET J=0

 +7        FOR 

               SET I=$ORDER(RACMSTR(I))

               IF I=""

                   QUIT 

               SET J=J+1

               IF J>3

                   QUIT 

               SET RACMSTR=$GET(RACMSTR)_$SELECT($GET(RACMSTR)="":"",1:",")_I

 +8        IF J>3

               SET RACMSTR=RACMSTR_"*"

 +9       ;remove ")"

           IF RASTR["("

               SET RASTR=$EXTRACT(RASTR,1,($LENGTH(RASTR)-1))

 +10      ;append CPTmods to str

           SET RASTR=RASTR_"-"_RACMSTR_$SELECT(RASTR["(":")",1:"")

 +11       QUIT