RADLQ3 ;HISC/GJC-Delq Status/Incomplete Rpt's ;5/7/97 15:58
;;5.0;Radiology/Nuclear Medicine;**87,93,47,125**;Mar 16, 1998;Build 1
; 11/15/07 BAY/KAM RA*5*87 Rem Call 217642 change pat ssn to display last four
; 05/09/08 BAY/KAM RA*5*93 Rem Call 246868 correct printing of *** OUTPATIENT ***
DISPXAM ; Display exam statuses for selected Imaging Types. These exam
; statuses need the 'DELINQUENT STATUS REPORT?' field tripped to
; 'yes' in file 72.
N RA,RAHD,UNDRLN,X,Y,Z
S RAHD(0)="The entries printed for this report will be based only"
S RAHD(1)="on exams that are in one of the following statuses:"
I '$D(RALL) D
. W !!?(IOM-$L(RAHD(0))\2),RAHD(0)
. W !?(IOM-$L(RAHD(1))\2),RAHD(1)
. Q
S X="" F S X=$O(^TMP($J,"RA I-TYPE",X)) Q:X']"" D Q:RAXIT
. I $D(^RA(72,"AA",X)) S Y="" K UNDRLN D
.. I '$D(RALL),($Y>(IOSL-4)) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF
.. I '$D(RALL) S $P(UNDRLN,"-",($L(X)+1))="" W !!?10,X,!?10,UNDRLN
.. F S Y=$O(^RA(72,"AA",X,Y)) Q:Y']"" D Q:RAXIT
... S Z=0 F S Z=+$O(^RA(72,"AA",X,Y,Z)) Q:'Z D Q:RAXIT
.... S RA(0)=$G(^RA(72,Z,0)),RA(.3)=$G(^RA(72,Z,.3))
.... S RA(.3,15)=$P(RA(.3),"^",15)
.... I RA(0)]"",(RA(.3)]""),(RA(.3,15)]""),("Yy"[RA(.3,15)) D
..... S RACRT(Z)=""
..... I '$D(RALL),($Y>(IOSL-4)) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D
...... W @IOF,!?10,X,!?10,UNDRLN
...... Q
..... W:'$D(RALL) !?15,$P(RA(0),"^")
..... Q
.... Q
... Q
.. Q
. Q
Q
OUTPUT ; Print out the results
N RAEOS I $D(RAVAR(0)),(RAVAR(0)'=RAVAR) S RAEOS=6
E S RAEOS=4
N RACN ;RA5P125 RACN overwrite
; Remedy 1287775
F I=1:1:$L(RANODE,"^") D
. S @$P("RACN^RAPRC^RAST^RADT^RAWHE^RARP^RASSN^RAVRFIED^RAIPHY^RATECH","^",I)=$P(RANODE,"^",I)
. Q
I $Y>(IOSL-RAEOS) D Q:RAXIT
. S RAXIT=$$EOS^RAUTL5() D:'RAXIT HDR^RADLQ2
. Q
; 05/09/08 BAY/KAM RA*5*93 Rem Call 246868 Added RAVAR Check to next
; line
I RAEOS=6,RAVAR="O" D
. N RASTR S RASTR="*** OUTPATIENT ***"
. S RASTR(0)=$$REPEAT^XLFSTR(" ",((IOM-($L(RASTR)*3))\2))
. S RASTR(1)=RASTR_RASTR(0)_RASTR_RASTR(0)_RASTR
. W !!,RASTR(1)
. Q
; Note: Inform the user that the following data will be for outpatients.
; Since only inpatient and outpatient is possibly stored, any
; change in the variable RAVAR will be a change to 'outpatient'.
; 11/15/07 BAY/KAM RA*5*87 Rem Call 217642 Added next line
S RASSN=$E(RASSN,8,11)
I IOM=132 D ;132 column format
. I $$USESSAN^RAHLRU1() D
.. W !,RANME,?RATAB(1),RACN,?RATAB(2)+7,RASSN,?RATAB(3),RADT,?RATAB(4)
.. W $E(RAWHE,1,25),?RATAB(5),RAVRFIED
.. W !?RATAB(6),$E(RAPRC,1,30),?RATAB(7),$E(RAST,1,30)
.. W ?RATAB(8),RARP,?RATAB(9),$E(RAIPHY,1,20),?RATAB(10),RATECH
. I '$$USESSAN^RAHLRU1() D
.. W !,RANME,?RATAB(1),RACN,?RATAB(2),RASSN,?RATAB(3),RADT,?RATAB(4)
.. W $E(RAWHE,1,25),?RATAB(5),RAVRFIED
.. W !?RATAB(6),$E(RAPRC,1,30),?RATAB(7),$E(RAST,1,30)
.. W ?RATAB(8),RARP,?RATAB(9),$E(RAIPHY,1,20),?RATAB(10),RATECH
. Q
E D ;default to 80 column
. I $$USESSAN^RAHLRU1() D
.. W !,$E(RANME,1,20),?RATAB(1),RACN,?RATAB(2)+7,RASSN,?RATAB(3),RADT
.. W ?RATAB(4),$E(RAWHE,1,15),?RATAB(5),RAVRFIED
.. W !?RATAB(6),$E(RAPRC,1,20),?RATAB(7),$E(RAST,1,11)
.. W ?RATAB(8),RARP,?RATAB(9),$E(RAIPHY,1,15),?RATAB(10),RATECH
. I '$$USESSAN^RAHLRU1() D
.. W !,$E(RANME,1,20),?RATAB(1),RACN,?RATAB(2),RASSN,?RATAB(3),RADT
.. W ?RATAB(4),$E(RAWHE,1,15),?RATAB(5),RAVRFIED
.. W !?RATAB(6),$E(RAPRC,1,20),?RATAB(7),$E(RAST,1,11)
.. W ?RATAB(8),RARP,?RATAB(9),$E(RAIPHY,1,15),?RATAB(10),RATECH
. Q
W !,RALN1
S RAVAR(0)=RAVAR ; track the patient status: inpatient -or- outpatient
Q
CHECK(DUZ) ; Check for the existence of RACCESS. Pass in user's DUZ!
S RAPSTX="" D SETVARS^RAPSET1(0)
Q
LIST ; List divisions and I-Types
N A,B S A=""
F S A=$O(^TMP($J,"RADLQ",A)) Q:A']"" D
. W !!,"Division: ",$P($G(^DIC(4,A,0)),"^"),!?3,"Imaging Type(s): "
. S B="" F S B=$O(^TMP($J,"RADLQ",A,B)) Q:B']"" D Q:RAXIT
.. I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HDR^RADLQ2 Q:RAXIT
.. W:$X>(IOM-30) !?($X+$L("Imaging Type(s): ")+3) W B,?($X+3)
.. Q
. Q
I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HDR^RADLQ2 Q:RAXIT
W !!?RATAB(6),"Total Over All Divisions: ",+$G(^TMP($J,"RADLQ"))
Q
EXIT ; Kill and quit
K %DT,BEGDATE,DIROUT,DIRUT,DTOUT,DUOUT,ENDDATE,I,INVMAXDT,RA,RA1,RA2
K RABEG,RACN,RACNI,RACRT,RADFN,RADIV,RADIVNM,RADT,RADTE,RADTI,RAEND
K RAEXAM,RAFLAG,RAHD,RAHEAD,RAIPHY,RAITYPE,RALN1,RALN2,RAMES,RANME
K RANODE,RAPAT,RAPG,RAPOP,RAPRC,RAQUIT,RAREGEX,RARP,RASORT1,RASORT2
K RASSN,RAST,RASTI,RASV,RATAB,RATECH,RAVAR,RAVRFIED,RAWHE,RAXIT
K X,Y,ZTDESC,ZTRTN,ZTSAVE
K ^TMP($J,"RA D-TYPE"),^TMP($J,"RA I-TYPE"),^TMP($J,"RADLQ")
K:$D(RAPSTX) RACCESS,RAPSTX D CLOSE^RAUTL
K DISYS,I,POP
Q
ZEROUT(SUB) ; Zero out the ^TMP($J global.
N X,Y,Z
S X="" F S X=$O(RACCESS(DUZ,"DIV-IMG",X)) Q:X']"" D
. Q:'$D(^TMP($J,"RA D-TYPE",X)) S Y=0
. F S Y=+$O(^TMP($J,"RA D-TYPE",X,Y)) Q:'Y D
.. S ^TMP($J,SUB,Y)=0,Z=""
.. F S Z=$O(RACCESS(DUZ,"DIV-IMG",X,Z)) Q:Z']"" D
... Q:'$D(^TMP($J,"RA I-TYPE",Z)) S ^TMP($J,SUB,Y,Z)=0
... I SUB="RADLQ" D
.... S:RASORT1'="B" ^TMP($J,SUB,Y,Z,RASORT1)=0
.... S:RASORT1="B" ^TMP($J,SUB,Y,Z,"I")=0,^TMP($J,SUB,Y,Z,"O")=0
.... Q
... Q
.. Q
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRADLQ3 5340 printed Jan 18, 2025@03:35:46 Page 2
RADLQ3 ;HISC/GJC-Delq Status/Incomplete Rpt's ;5/7/97 15:58
+1 ;;5.0;Radiology/Nuclear Medicine;**87,93,47,125**;Mar 16, 1998;Build 1
+2 ; 11/15/07 BAY/KAM RA*5*87 Rem Call 217642 change pat ssn to display last four
+3 ; 05/09/08 BAY/KAM RA*5*93 Rem Call 246868 correct printing of *** OUTPATIENT ***
DISPXAM ; Display exam statuses for selected Imaging Types. These exam
+1 ; statuses need the 'DELINQUENT STATUS REPORT?' field tripped to
+2 ; 'yes' in file 72.
+3 NEW RA,RAHD,UNDRLN,X,Y,Z
+4 SET RAHD(0)="The entries printed for this report will be based only"
+5 SET RAHD(1)="on exams that are in one of the following statuses:"
+6 IF '$DATA(RALL)
Begin DoDot:1
+7 WRITE !!?(IOM-$LENGTH(RAHD(0))\2),RAHD(0)
+8 WRITE !?(IOM-$LENGTH(RAHD(1))\2),RAHD(1)
+9 QUIT
End DoDot:1
+10 SET X=""
FOR
SET X=$ORDER(^TMP($JOB,"RA I-TYPE",X))
if X']""
QUIT
Begin DoDot:1
+11 IF $DATA(^RA(72,"AA",X))
SET Y=""
KILL UNDRLN
Begin DoDot:2
+12 IF '$DATA(RALL)
IF ($Y>(IOSL-4))
SET RAXIT=$$EOS^RAUTL5()
if RAXIT
QUIT
WRITE @IOF
+13 IF '$DATA(RALL)
SET $PIECE(UNDRLN,"-",($LENGTH(X)+1))=""
WRITE !!?10,X,!?10,UNDRLN
+14 FOR
SET Y=$ORDER(^RA(72,"AA",X,Y))
if Y']""
QUIT
Begin DoDot:3
+15 SET Z=0
FOR
SET Z=+$ORDER(^RA(72,"AA",X,Y,Z))
if 'Z
QUIT
Begin DoDot:4
+16 SET RA(0)=$GET(^RA(72,Z,0))
SET RA(.3)=$GET(^RA(72,Z,.3))
+17 SET RA(.3,15)=$PIECE(RA(.3),"^",15)
+18 IF RA(0)]""
IF (RA(.3)]"")
IF (RA(.3,15)]"")
IF ("Yy"[RA(.3,15))
Begin DoDot:5
+19 SET RACRT(Z)=""
+20 IF '$DATA(RALL)
IF ($Y>(IOSL-4))
SET RAXIT=$$EOS^RAUTL5()
if RAXIT
QUIT
Begin DoDot:6
+21 WRITE @IOF,!?10,X,!?10,UNDRLN
+22 QUIT
End DoDot:6
+23 if '$DATA(RALL)
WRITE !?15,$PIECE(RA(0),"^")
+24 QUIT
End DoDot:5
+25 QUIT
End DoDot:4
if RAXIT
QUIT
+26 QUIT
End DoDot:3
if RAXIT
QUIT
+27 QUIT
End DoDot:2
+28 QUIT
End DoDot:1
if RAXIT
QUIT
+29 QUIT
OUTPUT ; Print out the results
+1 NEW RAEOS
IF $DATA(RAVAR(0))
IF (RAVAR(0)'=RAVAR)
SET RAEOS=6
+2 IF '$TEST
SET RAEOS=4
+3 ;RA5P125 RACN overwrite
NEW RACN
+4 ; Remedy 1287775
+5 FOR I=1:1:$LENGTH(RANODE,"^")
Begin DoDot:1
+6 SET @$PIECE("RACN^RAPRC^RAST^RADT^RAWHE^RARP^RASSN^RAVRFIED^RAIPHY^RATECH","^",I)=$PIECE(RANODE,"^",I)
+7 QUIT
End DoDot:1
+8 IF $Y>(IOSL-RAEOS)
Begin DoDot:1
+9 SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HDR^RADLQ2
+10 QUIT
End DoDot:1
if RAXIT
QUIT
+11 ; 05/09/08 BAY/KAM RA*5*93 Rem Call 246868 Added RAVAR Check to next
+12 ; line
+13 IF RAEOS=6
IF RAVAR="O"
Begin DoDot:1
+14 NEW RASTR
SET RASTR="*** OUTPATIENT ***"
+15 SET RASTR(0)=$$REPEAT^XLFSTR(" ",((IOM-($LENGTH(RASTR)*3))\2))
+16 SET RASTR(1)=RASTR_RASTR(0)_RASTR_RASTR(0)_RASTR
+17 WRITE !!,RASTR(1)
+18 QUIT
End DoDot:1
+19 ; Note: Inform the user that the following data will be for outpatients.
+20 ; Since only inpatient and outpatient is possibly stored, any
+21 ; change in the variable RAVAR will be a change to 'outpatient'.
+22 ; 11/15/07 BAY/KAM RA*5*87 Rem Call 217642 Added next line
+23 SET RASSN=$EXTRACT(RASSN,8,11)
+24 ;132 column format
IF IOM=132
Begin DoDot:1
+25 IF $$USESSAN^RAHLRU1()
Begin DoDot:2
+26 WRITE !,RANME,?RATAB(1),RACN,?RATAB(2)+7,RASSN,?RATAB(3),RADT,?RATAB(4)
+27 WRITE $EXTRACT(RAWHE,1,25),?RATAB(5),RAVRFIED
+28 WRITE !?RATAB(6),$EXTRACT(RAPRC,1,30),?RATAB(7),$EXTRACT(RAST,1,30)
+29 WRITE ?RATAB(8),RARP,?RATAB(9),$EXTRACT(RAIPHY,1,20),?RATAB(10),RATECH
End DoDot:2
+30 IF '$$USESSAN^RAHLRU1()
Begin DoDot:2
+31 WRITE !,RANME,?RATAB(1),RACN,?RATAB(2),RASSN,?RATAB(3),RADT,?RATAB(4)
+32 WRITE $EXTRACT(RAWHE,1,25),?RATAB(5),RAVRFIED
+33 WRITE !?RATAB(6),$EXTRACT(RAPRC,1,30),?RATAB(7),$EXTRACT(RAST,1,30)
+34 WRITE ?RATAB(8),RARP,?RATAB(9),$EXTRACT(RAIPHY,1,20),?RATAB(10),RATECH
End DoDot:2
+35 QUIT
End DoDot:1
+36 ;default to 80 column
IF '$TEST
Begin DoDot:1
+37 IF $$USESSAN^RAHLRU1()
Begin DoDot:2
+38 WRITE !,$EXTRACT(RANME,1,20),?RATAB(1),RACN,?RATAB(2)+7,RASSN,?RATAB(3),RADT
+39 WRITE ?RATAB(4),$EXTRACT(RAWHE,1,15),?RATAB(5),RAVRFIED
+40 WRITE !?RATAB(6),$EXTRACT(RAPRC,1,20),?RATAB(7),$EXTRACT(RAST,1,11)
+41 WRITE ?RATAB(8),RARP,?RATAB(9),$EXTRACT(RAIPHY,1,15),?RATAB(10),RATECH
End DoDot:2
+42 IF '$$USESSAN^RAHLRU1()
Begin DoDot:2
+43 WRITE !,$EXTRACT(RANME,1,20),?RATAB(1),RACN,?RATAB(2),RASSN,?RATAB(3),RADT
+44 WRITE ?RATAB(4),$EXTRACT(RAWHE,1,15),?RATAB(5),RAVRFIED
+45 WRITE !?RATAB(6),$EXTRACT(RAPRC,1,20),?RATAB(7),$EXTRACT(RAST,1,11)
+46 WRITE ?RATAB(8),RARP,?RATAB(9),$EXTRACT(RAIPHY,1,15),?RATAB(10),RATECH
End DoDot:2
+47 QUIT
End DoDot:1
+48 WRITE !,RALN1
+49 ; track the patient status: inpatient -or- outpatient
SET RAVAR(0)=RAVAR
+50 QUIT
CHECK(DUZ) ; Check for the existence of RACCESS. Pass in user's DUZ!
+1 SET RAPSTX=""
DO SETVARS^RAPSET1(0)
+2 QUIT
LIST ; List divisions and I-Types
+1 NEW A,B
SET A=""
+2 FOR
SET A=$ORDER(^TMP($JOB,"RADLQ",A))
if A']""
QUIT
Begin DoDot:1
+3 WRITE !!,"Division: ",$PIECE($GET(^DIC(4,A,0)),"^"),!?3,"Imaging Type(s): "
+4 SET B=""
FOR
SET B=$ORDER(^TMP($JOB,"RADLQ",A,B))
if B']""
QUIT
Begin DoDot:2
+5 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HDR^RADLQ2
if RAXIT
QUIT
+6 if $X>(IOM-30)
WRITE !?($X+$LENGTH("Imaging Type(s): ")+3)
WRITE B,?($X+3)
+7 QUIT
End DoDot:2
if RAXIT
QUIT
+8 QUIT
End DoDot:1
+9 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HDR^RADLQ2
if RAXIT
QUIT
+10 WRITE !!?RATAB(6),"Total Over All Divisions: ",+$GET(^TMP($JOB,"RADLQ"))
+11 QUIT
EXIT ; Kill and quit
+1 KILL %DT,BEGDATE,DIROUT,DIRUT,DTOUT,DUOUT,ENDDATE,I,INVMAXDT,RA,RA1,RA2
+2 KILL RABEG,RACN,RACNI,RACRT,RADFN,RADIV,RADIVNM,RADT,RADTE,RADTI,RAEND
+3 KILL RAEXAM,RAFLAG,RAHD,RAHEAD,RAIPHY,RAITYPE,RALN1,RALN2,RAMES,RANME
+4 KILL RANODE,RAPAT,RAPG,RAPOP,RAPRC,RAQUIT,RAREGEX,RARP,RASORT1,RASORT2
+5 KILL RASSN,RAST,RASTI,RASV,RATAB,RATECH,RAVAR,RAVRFIED,RAWHE,RAXIT
+6 KILL X,Y,ZTDESC,ZTRTN,ZTSAVE
+7 KILL ^TMP($JOB,"RA D-TYPE"),^TMP($JOB,"RA I-TYPE"),^TMP($JOB,"RADLQ")
+8 if $DATA(RAPSTX)
KILL RACCESS,RAPSTX
DO CLOSE^RAUTL
+9 KILL DISYS,I,POP
+10 QUIT
ZEROUT(SUB) ; Zero out the ^TMP($J global.
+1 NEW X,Y,Z
+2 SET X=""
FOR
SET X=$ORDER(RACCESS(DUZ,"DIV-IMG",X))
if X']""
QUIT
Begin DoDot:1
+3 if '$DATA(^TMP($JOB,"RA D-TYPE",X))
QUIT
SET Y=0
+4 FOR
SET Y=+$ORDER(^TMP($JOB,"RA D-TYPE",X,Y))
if 'Y
QUIT
Begin DoDot:2
+5 SET ^TMP($JOB,SUB,Y)=0
SET Z=""
+6 FOR
SET Z=$ORDER(RACCESS(DUZ,"DIV-IMG",X,Z))
if Z']""
QUIT
Begin DoDot:3
+7 if '$DATA(^TMP($JOB,"RA I-TYPE",Z))
QUIT
SET ^TMP($JOB,SUB,Y,Z)=0
+8 IF SUB="RADLQ"
Begin DoDot:4
+9 if RASORT1'="B"
SET ^TMP($JOB,SUB,Y,Z,RASORT1)=0
+10 if RASORT1="B"
SET ^TMP($JOB,SUB,Y,Z,"I")=0
SET ^TMP($JOB,SUB,Y,Z,"O")=0
+11 QUIT
End DoDot:4
+12 QUIT
End DoDot:3
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 QUIT
