Routine: BRARPT3

BRARPT3 ; IHS/ADC/PDW - Radiology Exam Roster by Technologist, Proc. ;

 ;;5.0;Radiology/Nuclear Medicine;;Feb 20, 2004

 D ^XBKVAR K BRADIC

PROMPT ;

 S:'$D(IOF) IOF="!!"

 W @IOF,!?19 F I=1:1:40 W "-"

 W !?19,"| ***  FILM USAGE BY TECHNOLOGIST  *** |"

 W !?19 F I=1:1:40 W "-"

 ;---> GET DATE RANGE, RETURNS "RABEGDT" AND "RAENDDT".

 D DATE^RAUTL G:RAPOP EXIT

 S RABEGDT=BEGDATE,RAENDDT=ENDDATE

 S BRAY=0

TECH ;---> SELECT TECHNOLOGISTS.

 S BRADIR="technologist",BRAVAR="RATECH",BRAGBL="^VA(200,"

 S BRADIC=200,BRADIC("S")="I $D(^VA(200,""ARC"",""T"",Y))"

 D SELECT^BRARPT1 K BRADIC("S")

 G:'BRAY EXIT

PROC ;---> SELECT PROCEDURES.

 S BRADIR="procedure",BRADIC=71

 S BRAVAR="RAPRC",BRAGBL="^RAMIS(71,"

 D SELECT^BRARPT1

 G:'BRAY EXIT

 ;G TASKMAN

EXAMS ;---> PROMPT FOR DISPLAYING EACH EXAM.

 W ! S DIR("A")="Do you wish to display each exam and film size"

 S DIR(0)="Y",DIR("B")="Y",RAEX=0

 S DIR("?",1)="Answer ""YES"" to display each individual exam and"

 S DIR("?",2)="film size under each Radiology Procedure."

 S DIR("?")="Answer ""NO"" to display only procedures and their totals."

 D ^DIR K DIR,X

 I $D(DIRUT) G EXIT

 I Y S RAEX=1 K Y

TASKMAN ;---> TASKMAN STUFF.

 S ZTRTN="START^BRARPT3"

 F RASV="RABEGDT","RAENDDT","RAEX","RAPRC(","RATECH(" D

 .S ZTSAVE(RASV)=""

DEV ;---> GET DEVICE AND/OR QUEUE.

 W ! D ZIS^RAUTL G:RAPOP EXIT

START ;---> TASKMAN STARTING POINT.

 D SORT

PRINT D ^BRARPT4

EXIT ;

 K DIC,DIR,DIRUT,I,K,L,N,O,P,RAPOP,Q,R,RABEGDT,RACNI,RAD0,RADFN,RADIAG

 K RADTE,RADTI,RAEND,RAENDDT,RAEX,RAMES,RANAME,RAP0,RAPAGE,RAPRC,RARAD

 K RASV,RATCH,RATECH,BRADIC,BRADIR,BRAGBL,BRAVAR,BRAY

 K ^TMP($J,"RA"),X,Y,ZTDESC,ZTRTN,ZTSAVE

SORT ;---> SORT EXAMS FOR SELECTED CRITERIA.

 K ^TMP($J,"RA")

 S RADTE=RABEGDT-.0001,RAEND=RAENDDT+.9999

 F  S RADTE=$O(^RADPT("AR",RADTE)) Q:RADTE'>0!(RADTE>RAEND)  D

 .S RADTI=9999999.9999-RADTE

 .D RADFN

RADFN S RADFN=0

 F  S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:RADFN'>0  D

 .Q:'$D(^RADPT(RADFN,"DT",RADTI,0))

 .;---> RAD0=ZERO NODE OF VISIT.

 .S RAD0=^RADPT(RADFN,"DT",RADTI,0)

 .D RACNI

RACNI S RACNI=0

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

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

 .;---> RAP0=ZERO NODE OF EXAM.

 .S RAP0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)

 .;---> IF NOT ALL PROCEDURES, THEN QUIT IF NOT ONE OF THE SELECTED.

 .Q:'$P(RAP0,U,2)  I '$D(RAPRC("ALL")) Q:'$D(RAPRC($P(RAP0,U,2)))

 .;---> LOOP THROUGH TECHS.

 .N F,T

 .S T=0 F  S T=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",T)) Q:'T  D

 ..S RATECH=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",T,0),U)

 ..Q:'RATECH  Q:('$D(RATECH(RATECH)))&('$D(RATECH("ALL")))

 ..;---> LOOP THROUGH FILM SIZES.

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

 ...S RAFILM0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"F",F,0),RAFILM=+^(0)

 ...Q:'RAFILM

 ...D SET

SET ;

 ;---> GET DIVISION SUBSCRIPT.

 S RADIV=$S($D(^RA(79,+$P(RAD0,"^",3),0)):+$P(RAD0,"^",3),1:9999)

 ;---> GET TECHNOLOGIST SUBSCRIPT.

 Q:'$D(^VA(200,RATECH,0))  S RATCH=$E($P(^(0),U),1,30)

 ;---> GET PROCEDURE SUBSCRIPT.

 S RAPRC=$E($P(^RAMIS(71,$P(RAP0,U,2),0),U),1,29)

 ;---> GET PATIENT NAME SUBSCRIPT.

 S RANAME=$P(^DPT(RADFN,0),U)

 ;---> SET ^TMP(NODE=CASE#^CHART#^FILM SIZE^TOTAL FILMS^RETAKES

 ;S X=$P(RAP0,U)_U_$$HRCN^BDGF2(RADFN,DUZ("2"))_U_RAFILM

 S X=$P(RAP0,U)_U_$$HRCN^BDGF2(RADFN,DUZ("2"))_U_$P(RAFILM0,U,2)_U_$P(RAFILM0,U,9)

 S ^TMP($J,"RA",RADIV,RATCH,RAPRC,RANAME,RADTE,RAFILM)=X

BRARPT3   ; IHS/ADC/PDW - Radiology Exam Roster by Technologist, Proc. ;

 +1       ;;5.0;Radiology/Nuclear Medicine;;Feb 20, 2004

 +2       ;

 +3        DO ^XBKVAR

           KILL BRADIC

PROMPT    ;

 +1        IF '$DATA(IOF)

               SET IOF="!!"

 +2        WRITE @IOF,!?19

           FOR I=1:1:40

               WRITE "-"

 +3        WRITE !?19,"| ***  FILM USAGE BY TECHNOLOGIST  *** |"

 +4        WRITE !?19

           FOR I=1:1:40

               WRITE "-"

 +5       ;

 +6       ;---> GET DATE RANGE, RETURNS "RABEGDT" AND "RAENDDT".

 +7        DO DATE^RAUTL

           IF RAPOP

               GOTO EXIT

 +8        SET RABEGDT=BEGDATE

           SET RAENDDT=ENDDATE

 +9       ;

 +10       SET BRAY=0

TECH      ;---> SELECT TECHNOLOGISTS.

 +1        SET BRADIR="technologist"

           SET BRAVAR="RATECH"

           SET BRAGBL="^VA(200,"

 +2        SET BRADIC=200

           SET BRADIC("S")="I $D(^VA(200,""ARC"",""T"",Y))"

 +3        DO SELECT^BRARPT1

           KILL BRADIC("S")

 +4        IF 'BRAY

               GOTO EXIT

 +5       ;

PROC      ;---> SELECT PROCEDURES.

 +1        SET BRADIR="procedure"

           SET BRADIC=71

 +2        SET BRAVAR="RAPRC"

           SET BRAGBL="^RAMIS(71,"

 +3        DO SELECT^BRARPT1

 +4        IF 'BRAY

               GOTO EXIT

 +5       ;

 +6       ;

 +7       ;G TASKMAN

EXAMS     ;---> PROMPT FOR DISPLAYING EACH EXAM.

 +1        WRITE !

           SET DIR("A")="Do you wish to display each exam and film size"

 +2        SET DIR(0)="Y"

           SET DIR("B")="Y"

           SET RAEX=0

 +3        SET DIR("?",1)="Answer ""YES"" to display each individual exam and"

 +4        SET DIR("?",2)="film size under each Radiology Procedure."

 +5        SET DIR("?")="Answer ""NO"" to display only procedures and their totals."

 +6        DO ^DIR

           KILL DIR,X

 +7        IF $DATA(DIRUT)

               GOTO EXIT

 +8        IF Y

               SET RAEX=1

               KILL Y

 +9       ;

TASKMAN   ;---> TASKMAN STUFF.

 +1        SET ZTRTN="START^BRARPT3"

 +2        FOR RASV="RABEGDT","RAENDDT","RAEX","RAPRC(","RATECH("

               Begin DoDot:1

 +3                SET ZTSAVE(RASV)=""

               End DoDot:1

 +4       ;

DEV       ;---> GET DEVICE AND/OR QUEUE.

 +1        WRITE !

           DO ZIS^RAUTL

           IF RAPOP

               GOTO EXIT

 +2       ;

START     ;---> TASKMAN STARTING POINT.

 +1        DO SORT

 +2       ;

PRINT      DO ^BRARPT4

 +1       ;

EXIT      ;

 +1        KILL DIC,DIR,DIRUT,I,K,L,N,O,P,RAPOP,Q,R,RABEGDT,RACNI,RAD0,RADFN,RADIAG

 +2        KILL RADTE,RADTI,RAEND,RAENDDT,RAEX,RAMES,RANAME,RAP0,RAPAGE,RAPRC,RARAD

 +3        KILL RASV,RATCH,RATECH,BRADIC,BRADIR,BRAGBL,BRAVAR,BRAY

 +4        KILL ^TMP($JOB,"RA"),X,Y,ZTDESC,ZTRTN,ZTSAVE

 +5        QUIT

 +6       ;

 +7       ;

SORT      ;---> SORT EXAMS FOR SELECTED CRITERIA.

 +1        KILL ^TMP($JOB,"RA")

 +2        SET RADTE=RABEGDT-.0001

           SET RAEND=RAENDDT+.9999

 +3        FOR

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

               IF RADTE'>0!(RADTE>RAEND)

                   QUIT

               Begin DoDot:1

 +4                SET RADTI=9999999.9999-RADTE

 +5                DO RADFN

               End DoDot:1

 +6        QUIT

 +7       ;

RADFN      SET RADFN=0

 +1        FOR

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

               IF RADFN'>0

                   QUIT

               Begin DoDot:1

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

                       QUIT

 +3       ;---> RAD0=ZERO NODE OF VISIT.

 +4                SET RAD0=^RADPT(RADFN,"DT",RADTI,0)

 +5                DO RACNI

               End DoDot:1

 +6        QUIT

 +7       ;

RACNI      SET RACNI=0

 +1        FOR

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

               IF RACNI'>0

                   QUIT

               Begin DoDot:1

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

                       QUIT

 +3       ;---> RAP0=ZERO NODE OF EXAM.

 +4                SET RAP0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)

 +5       ;---> IF NOT ALL PROCEDURES, THEN QUIT IF NOT ONE OF THE SELECTED.

 +6                IF '$PIECE(RAP0,U,2)

                       QUIT

                   IF '$DATA(RAPRC("ALL"))

                       IF '$DATA(RAPRC($PIECE(RAP0,U,2)))

                           QUIT

 +7       ;---> LOOP THROUGH TECHS.

 +8                NEW F,T

 +9                SET T=0

FOR

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

                       IF 'T

                           QUIT

                       Begin DoDot:2

 +10                       SET RATECH=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",T,0),U)

 +11                       IF 'RATECH

                               QUIT

                           IF ('$DATA(RATECH(RATECH)))&('$DATA(RATECH("ALL")))

                               QUIT

 +12      ;---> LOOP THROUGH FILM SIZES.

 +13                       SET F=0

FOR

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

                               IF 'F

                                   QUIT

                               Begin DoDot:3

 +14                               SET RAFILM0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"F",F,0)

                                   SET RAFILM=+^(0)

 +15                               IF 'RAFILM

                                       QUIT

 +16                               DO SET

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +17       QUIT

SET       ;

 +1       ;---> GET DIVISION SUBSCRIPT.

 +2        SET RADIV=$SELECT($DATA(^RA(79,+$PIECE(RAD0,"^",3),0)):+$PIECE(RAD0,"^",3),1:9999)

 +3       ;---> GET TECHNOLOGIST SUBSCRIPT.

 +4        IF '$DATA(^VA(200,RATECH,0))

               QUIT

           SET RATCH=$EXTRACT($PIECE(^(0),U),1,30)

 +5       ;---> GET PROCEDURE SUBSCRIPT.

 +6        SET RAPRC=$EXTRACT($PIECE(^RAMIS(71,$PIECE(RAP0,U,2),0),U),1,29)

 +7       ;---> GET PATIENT NAME SUBSCRIPT.

 +8        SET RANAME=$PIECE(^DPT(RADFN,0),U)

 +9       ;---> SET ^TMP(NODE=CASE#^CHART#^FILM SIZE^TOTAL FILMS^RETAKES

 +10      ;S X=$P(RAP0,U)_U_$$HRCN^BDGF2(RADFN,DUZ("2"))_U_RAFILM

 +11       SET X=$PIECE(RAP0,U)_U_$$HRCN^BDGF2(RADFN,DUZ("2"))_U_$PIECE(RAFILM0,U,2)_U_$PIECE(RAFILM0,U,9)

 +12       SET ^TMP($JOB,"RA",RADIV,RATCH,RAPRC,RANAME,RADTE,RAFILM)=X

 +13       QUIT

BRARPT3.m