RADLQ3 ;HISC/GJC-Delq Status/Incomplete Rpt's ;5/7/97 15:58 [ 12/05/2011 10:32 AM ]
;;5.0;Radiology/Nuclear Medicine;**87,93,47**;Mar 16, 1998;Build 21
; 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
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
;
;IHS/CMI/DAY - Patch 1004 - Use 6 digit HRNO, not last last 4 of SSN
;S RASSN=$E(RASSN,8,11)
;End Patch
;
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
RADLQ3 ;HISC/GJC-Delq Status/Incomplete Rpt's ;5/7/97 15:58 [ 12/05/2011 10:32 AM ]
+1 ;;5.0;Radiology/Nuclear Medicine;**87,93,47**;Mar 16, 1998;Build 21
+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 FOR I=1:1:$LENGTH(RANODE,"^")
Begin DoDot:1
+4 SET @$PIECE("RACN^RAPRC^RAST^RADT^RAWHE^RARP^RASSN^RAVRFIED^RAIPHY^RATECH","^",I)=$PIECE(RANODE,"^",I)
+5 QUIT
End DoDot:1
+6 IF $Y>(IOSL-RAEOS)
Begin DoDot:1
+7 SET RAXIT=$$EOS^RAUTL5()
IF 'RAXIT
DO HDR^RADLQ2
+8 QUIT
End DoDot:1
IF RAXIT
QUIT
+9 ; 05/09/08 BAY/KAM RA*5*93 Rem Call 246868 Added RAVAR Check to next
+10 ; line
+11 IF RAEOS=6
IF RAVAR="O"
Begin DoDot:1
+12 NEW RASTR
SET RASTR="*** OUTPATIENT ***"
+13 SET RASTR(0)=$$REPEAT^XLFSTR(" ",((IOM-($LENGTH(RASTR)*3))\2))
+14 SET RASTR(1)=RASTR_RASTR(0)_RASTR_RASTR(0)_RASTR
+15 WRITE !!,RASTR(1)
+16 QUIT
End DoDot:1
+17 ; Note: Inform the user that the following data will be for outpatients.
+18 ; Since only inpatient and outpatient is possibly stored, any
+19 ; change in the variable RAVAR will be a change to 'outpatient'.
+20 ; 11/15/07 BAY/KAM RA*5*87 Rem Call 217642 Added next line
+21 ;
+22 ;IHS/CMI/DAY - Patch 1004 - Use 6 digit HRNO, not last last 4 of SSN
+23 ;S RASSN=$E(RASSN,8,11)
+24 ;End Patch
+25 ;
+26 ;132 column format
IF IOM=132
Begin DoDot:1
+27 IF $$USESSAN^RAHLRU1()
Begin DoDot:2
+28 WRITE !,RANME,?RATAB(1),RACN,?RATAB(2)+7,RASSN,?RATAB(3),RADT,?RATAB(4)
+29 WRITE $EXTRACT(RAWHE,1,25),?RATAB(5),RAVRFIED
+30 WRITE !?RATAB(6),$EXTRACT(RAPRC,1,30),?RATAB(7),$EXTRACT(RAST,1,30)
+31 WRITE ?RATAB(8),RARP,?RATAB(9),$EXTRACT(RAIPHY,1,20),?RATAB(10),RATECH
End DoDot:2
+32 IF '$$USESSAN^RAHLRU1()
Begin DoDot:2
+33 WRITE !,RANME,?RATAB(1),RACN,?RATAB(2),RASSN,?RATAB(3),RADT,?RATAB(4)
+34 WRITE $EXTRACT(RAWHE,1,25),?RATAB(5),RAVRFIED
+35 WRITE !?RATAB(6),$EXTRACT(RAPRC,1,30),?RATAB(7),$EXTRACT(RAST,1,30)
+36 WRITE ?RATAB(8),RARP,?RATAB(9),$EXTRACT(RAIPHY,1,20),?RATAB(10),RATECH
End DoDot:2
+37 QUIT
End DoDot:1
+38 ;default to 80 column
IF '$TEST
Begin DoDot:1
+39 IF $$USESSAN^RAHLRU1()
Begin DoDot:2
+40 WRITE !,$EXTRACT(RANME,1,20),?RATAB(1),RACN,?RATAB(2)+7,RASSN,?RATAB(3),RADT
+41 WRITE ?RATAB(4),$EXTRACT(RAWHE,1,15),?RATAB(5),RAVRFIED
+42 WRITE !?RATAB(6),$EXTRACT(RAPRC,1,20),?RATAB(7),$EXTRACT(RAST,1,11)
+43 WRITE ?RATAB(8),RARP,?RATAB(9),$EXTRACT(RAIPHY,1,15),?RATAB(10),RATECH
End DoDot:2
+44 IF '$$USESSAN^RAHLRU1()
Begin DoDot:2
+45 WRITE !,$EXTRACT(RANME,1,20),?RATAB(1),RACN,?RATAB(2),RASSN,?RATAB(3),RADT
+46 WRITE ?RATAB(4),$EXTRACT(RAWHE,1,15),?RATAB(5),RAVRFIED
+47 WRITE !?RATAB(6),$EXTRACT(RAPRC,1,20),?RATAB(7),$EXTRACT(RAST,1,11)
+48 WRITE ?RATAB(8),RARP,?RATAB(9),$EXTRACT(RAIPHY,1,15),?RATAB(10),RATECH
End DoDot:2
+49 QUIT
End DoDot:1
+50 WRITE !,RALN1
+51 ; track the patient status: inpatient -or- outpatient
SET RAVAR(0)=RAVAR
+52 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
