RAMIS ;HISC/CAH,GJC,FPT AISC/MJK-Radiology AMIS Report ;4/15/96 12:49
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) S RAPSTX=""
I $O(RACCESS(DUZ,""))="" D ACCVIO^RAUTL19 Q
W !!,"NOTE: This output should be queued to a printer that supports 132 columns.",!
D CHK^RAMIS2 I '$D(RADFLAG) G Q^RAMIS1
S ZTRTN="START^RAMIS",ZTSAVE("BEGDATE")="",ZTSAVE("ENDDATE")="",ZTSAVE("^TMP($J,""RA D-TYPE"",")="" D DATE^RAUTL G:RAPOP Q^RAMIS1
D SHOWSTAT
DEV W ! D ZIS^RAUTL G:RAPOP Q^RAMIS1
START ; Start processing here
S:$D(ZTQUEUED) ZTREQ="@"
U IO K ^TMP($J,"RAMIS") S RAXIT=0
S RABEG=BEGDATE-.0001,RAEND=ENDDATE+.9999,D="TOT",RACRT=8
D CRIT^RAUTL1 D INIT
F RADTE=RABEG:0:RAEND S RADTE=$O(^RADPT("AR",RADTE)) Q:RADTE'>0!(RADTE>RAEND) D Q:RAXIT
. S RADFN=0
. F S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:RADFN'>0 D RADTI Q:RAXIT
. Q
G:'RAXIT ^RAMIS1
G Q^RAMIS1
;
RADTI ; Obtain the Registered Exams node
F RADTI=0:0 K RA20,RABILAT,RA21H,RA21B,RAOR,RAPORT,RAORFL,RAPORTFL,RAVST,RACPT S RADTI=$O(^RADPT("AR",RADTE,RADFN,RADTI)) Q:RADTI'>0!(RAXIT) I $D(^RADPT(RADFN,"DT",RADTI,0)) S RAD0=^(0) D RACNI
Q
RACNI ; Obtain the Examinations node
S (RADIVN,Y)=+$P(RAD0,U,3) Q:RADIVN'>0
S C=$P(^DD(70.02,3,0),U,2) D Y^DIQ Q:Y="" S RADIVN(0)=Y
I $D(^TMP($J,"RA D-TYPE",RADIVN(0),RADIVN))[0 Q
F RACNI=0:0 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0!(RAXIT) I $D(^(RACNI,0)) S RAP0=^(0) D CHK:$D(RACRT(+$P(RAP0,"^",3)))
Q
;
CHK I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 Q:RAXIT
S RADIV=$S($D(^RA(79,+$P(RAD0,"^",3),0)):+$P(RAD0,"^",3),1:99) I '$D(^TMP($J,"RAMIS",RADIV)) S D=RADIV D INIT
S C=$S($D(^DIC(42,+$P(RAP0,"^",6),0)):"IN",1:"OUT")
I '$D(RAVST) S RAVST="" F D=RADIV,"TOT" S ^(C)=^TMP($J,"RAMIS",D,"VST",C)+1
F I=0:0 S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"F",I)) Q:I'>0!(RAXIT) I $D(^(I,0)) S X=^(0) I $D(^RA(78.4,+X,0)) S T=$S($P(^(0),"^",2)'="Y":"FLM",1:"CINE"),X=+$P(X,"^",2) D FLM
F I=0:0 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,+$P(RAP0,"^",2),0)) S RAPRI=^(0),RAPRC=$E($P(RAPRI,"^"),1,30) Q:'$D(^(2))!($D(RACPT(+$P(RAPRI,"^",9)))) S RACPT(+$P(RAPRI,"^",9))=""
F I=0:0 S I=$O(^RAMIS(71,+$P(RAP0,"^",2),2,I)) Q:I'>0!(RAXIT) I $D(^(I,0)) S RAZ=^(0),RAMJ=$S($D(^RAMIS(71.1,+RAZ,0)):^(0),1:"") D RAPRC
Q:'$D(RAMIS(1)) F I=0:0 S I=$O(RAMIS(I)) Q:I'>0!(RAXIT) S A=RAMIS(I),RAWT=RAWT(I),RAMUL=RAMUL(I),RACT=RACT(I) D STORE
K RAMIS,RAWT,RAMUL,RACT,RAZ,RAMJ,RAMULP,RAMULPFL,RAPORT,RAOR,RABILAT,RA21H,RA21B,RA20 Q
;
STORE ; Store data into ^TMP($J,"RAMIS")
I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 Q:RAXIT
I A=20,$D(RA20) Q
I A=21,$D(RA21H),RACT="H" Q
I A=21,$D(RA21B),RACT="B" Q
S:A=20 RA20="" I A=21 S:RACT="H" RA21H="" S:RACT="B" RA21B=""
I '$D(RAORFL),$D(RAOR) S RAORFL="" F D=RADIV,"TOT" S ^(C)=^TMP($J,"RAMIS",D,25,"EX",C)+1
I '$D(RAPORTFL),$D(RAPORT) S RAPORTFL="" F D=RADIV,"TOT" S ^(C)=^TMP($J,"RAMIS",D,26,"EX",C)+1
I '$D(RAMULPFL),$D(RAMULP) S RAMULPFL="" F D=RADIV,"TOT" S ^(C)=^TMP($J,"RAMIS",D,"MULP","EX",C)+1
F D=RADIV,"TOT" S ^(C)=^TMP($J,"RAMIS",D,A,"EX",C)+RAMUL
F D=RADIV,"TOT" S ^(C)=^TMP($J,"RAMIS",D,A,"WT",C)+(RAMUL*RAWT)
I $D(RAOR) F D=RADIV,"TOT" S ^(C)=^TMP($J,"RAMIS",D,25,"WT",C)+(RAMUL*RAWT)
I $D(RAPORT) F D=RADIV,"TOT" S ^(C)=^TMP($J,"RAMIS",D,26,"WT",C)+(RAMUL*RAWT)
I $D(RAMULP) F D=RADIV,"TOT" S ^(C)=^TMP($J,"RAMIS",D,"MULP","WT",C)+(RAMUL*RAWT)
F D=RADIV,"TOT" S ^(C)=^TMP($J,"RAMIS",D,"TOT","EX",C)+RAMUL
F D=RADIV,"TOT" S ^(C)=^TMP($J,"RAMIS",D,"TOT","WT",C)+(RAMUL*RAWT)
Q
;
INIT ; Initialize the ^TMP($J,"RAMIS" global to zero.
F A=1:1:27,99,"TOT","MULP" F T="EX","WT" F C="IN","OUT" S ^TMP($J,"RAMIS",D,A,T,C)=0
F T="FLM","CINE","CINERUNS","VST" F C="IN","OUT" S ^TMP($J,"RAMIS",D,T,C)=0
Q
;
RAPRC I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 Q:RAXIT
I +RAZ=25 S RAOR="" Q
I +RAZ=26 S RAPORT="" Q
S:$P(RAZ,U,3)="Y" RABILAT="" F J=1:1 I '$D(RAMIS(J)) S RAMIS(J)=$S(RAMJ]"":+RAZ,1:99),RAWT(J)=+$P(RAMJ,U,2),RAMUL(J)=$S(+$P(RAZ,U,2)>0:+$P(RAZ,U,2),1:1) S:$D(RABILAT)&(RAMUL(J)<2) RAMUL(J)=RAMUL(J)*2 S RACT(J)=$P(RAZ,U,4) S:J>1 RAMULP="" Q
K RABILAT
Q
;
FLM I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 Q:RAXIT
F D=RADIV,"TOT" S ^(C)=^TMP($J,"RAMIS",D,T,C)+X S:T="CINE" ^(C)=^TMP($J,"RAMIS",D,"CINERUNS",C)+1
Q
SHOWSTAT ;
K ^TMP($J,"RA I-TYPE") N RA2,RAXIT S (RA2,RAXIT)=""
F S RA2=$O(^RA(72,"AA",RA2)) Q:RA2="" S ^TMP($J,"RA I-TYPE",RA2)=""
D DISPXAM^RALWKL1(8) K ^TMP($J,"RA I-TYPE")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAMIS 4652 printed Apr 09, 2024@21:42:30 Page 2
RAMIS ;HISC/CAH,GJC,FPT AISC/MJK-Radiology AMIS Report ;4/15/96 12:49
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
+2 IF $ORDER(RACCESS(DUZ,""))=""
DO SETVARS^RAPSET1(0)
SET RAPSTX=""
+3 IF $ORDER(RACCESS(DUZ,""))=""
DO ACCVIO^RAUTL19
QUIT
+4 WRITE !!,"NOTE: This output should be queued to a printer that supports 132 columns.",!
+5 DO CHK^RAMIS2
IF '$DATA(RADFLAG)
GOTO Q^RAMIS1
+6 SET ZTRTN="START^RAMIS"
SET ZTSAVE("BEGDATE")=""
SET ZTSAVE("ENDDATE")=""
SET ZTSAVE("^TMP($J,""RA D-TYPE"",")=""
DO DATE^RAUTL
if RAPOP
GOTO Q^RAMIS1
+7 DO SHOWSTAT
DEV WRITE !
DO ZIS^RAUTL
if RAPOP
GOTO Q^RAMIS1
START ; Start processing here
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 USE IO
KILL ^TMP($JOB,"RAMIS")
SET RAXIT=0
+3 SET RABEG=BEGDATE-.0001
SET RAEND=ENDDATE+.9999
SET D="TOT"
SET RACRT=8
+4 DO CRIT^RAUTL1
DO INIT
+5 FOR RADTE=RABEG:0:RAEND
SET RADTE=$ORDER(^RADPT("AR",RADTE))
if RADTE'>0!(RADTE>RAEND)
QUIT
Begin DoDot:1
+6 SET RADFN=0
+7 FOR
SET RADFN=$ORDER(^RADPT("AR",RADTE,RADFN))
if RADFN'>0
QUIT
DO RADTI
if RAXIT
QUIT
+8 QUIT
End DoDot:1
if RAXIT
QUIT
+9 if 'RAXIT
GOTO ^RAMIS1
+10 GOTO Q^RAMIS1
+11 ;
RADTI ; Obtain the Registered Exams node
+1 FOR RADTI=0:0
KILL RA20,RABILAT,RA21H,RA21B,RAOR,RAPORT,RAORFL,RAPORTFL,RAVST,RACPT
SET RADTI=$ORDER(^RADPT("AR",RADTE,RADFN,RADTI))
if RADTI'>0!(RAXIT)
QUIT
IF $DATA(^RADPT(RADFN,"DT",RADTI,0))
SET RAD0=^(0)
DO RACNI
+2 QUIT
RACNI ; Obtain the Examinations node
+1 SET (RADIVN,Y)=+$PIECE(RAD0,U,3)
if RADIVN'>0
QUIT
+2 SET C=$PIECE(^DD(70.02,3,0),U,2)
DO Y^DIQ
if Y=""
QUIT
SET RADIVN(0)=Y
+3 IF $DATA(^TMP($JOB,"RA D-TYPE",RADIVN(0),RADIVN))[0
QUIT
+4 FOR RACNI=0:0
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
if RACNI'>0!(RAXIT)
QUIT
IF $DATA(^(RACNI,0))
SET RAP0=^(0)
if $DATA(RACRT(+$PIECE(RAP0,"^",3)))
DO CHK
+5 QUIT
+6 ;
CHK IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
if $GET(ZTSTOP)=1
SET RAXIT=1
if RAXIT
QUIT
+1 SET RADIV=$SELECT($DATA(^RA(79,+$PIECE(RAD0,"^",3),0)):+$PIECE(RAD0,"^",3),1:99)
IF '$DATA(^TMP($JOB,"RAMIS",RADIV))
SET D=RADIV
DO INIT
+2 SET C=$SELECT($DATA(^DIC(42,+$PIECE(RAP0,"^",6),0)):"IN",1:"OUT")
+3 IF '$DATA(RAVST)
SET RAVST=""
FOR D=RADIV,"TOT"
SET ^(C)=^TMP($JOB,"RAMIS",D,"VST",C)+1
+4 FOR I=0:0
SET I=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"F",I))
if I'>0!(RAXIT)
QUIT
IF $DATA(^(I,0))
SET X=^(0)
IF $DATA(^RA(78.4,+X,0))
SET T=$SELECT($PIECE(^(0),"^",2)'="Y":"FLM",1:"CINE")
SET X=+$PIECE(X,"^",2)
DO FLM
+5 FOR I=0:0
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)
+6 if '$DATA(^RAMIS(71,+$PIECE(RAP0,"^",2),0))
QUIT
SET RAPRI=^(0)
SET RAPRC=$EXTRACT($PIECE(RAPRI,"^"),1,30)
if '$DATA(^(2))!($DATA(RACPT(+$PIECE(RAPRI,"^",9))))
QUIT
SET RACPT(+$PIECE(RAPRI,"^",9))=""
+7 FOR I=0:0
SET I=$ORDER(^RAMIS(71,+$PIECE(RAP0,"^",2),2,I))
if I'>0!(RAXIT)
QUIT
IF $DATA(^(I,0))
SET RAZ=^(0)
SET RAMJ=$SELECT($DATA(^RAMIS(71.1,+RAZ,0)):^(0),1:"")
DO RAPRC
+8 if '$DATA(RAMIS(1))
QUIT
FOR I=0:0
SET I=$ORDER(RAMIS(I))
if I'>0!(RAXIT)
QUIT
SET A=RAMIS(I)
SET RAWT=RAWT(I)
SET RAMUL=RAMUL(I)
SET RACT=RACT(I)
DO STORE
+9 KILL RAMIS,RAWT,RAMUL,RACT,RAZ,RAMJ,RAMULP,RAMULPFL,RAPORT,RAOR,RABILAT,RA21H,RA21B,RA20
QUIT
+10 ;
STORE ; Store data into ^TMP($J,"RAMIS")
+1 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
if $GET(ZTSTOP)=1
SET RAXIT=1
if RAXIT
QUIT
+2 IF A=20
IF $DATA(RA20)
QUIT
+3 IF A=21
IF $DATA(RA21H)
IF RACT="H"
QUIT
+4 IF A=21
IF $DATA(RA21B)
IF RACT="B"
QUIT
+5 if A=20
SET RA20=""
IF A=21
if RACT="H"
SET RA21H=""
if RACT="B"
SET RA21B=""
+6 IF '$DATA(RAORFL)
IF $DATA(RAOR)
SET RAORFL=""
FOR D=RADIV,"TOT"
SET ^(C)=^TMP($JOB,"RAMIS",D,25,"EX",C)+1
+7 IF '$DATA(RAPORTFL)
IF $DATA(RAPORT)
SET RAPORTFL=""
FOR D=RADIV,"TOT"
SET ^(C)=^TMP($JOB,"RAMIS",D,26,"EX",C)+1
+8 IF '$DATA(RAMULPFL)
IF $DATA(RAMULP)
SET RAMULPFL=""
FOR D=RADIV,"TOT"
SET ^(C)=^TMP($JOB,"RAMIS",D,"MULP","EX",C)+1
+9 FOR D=RADIV,"TOT"
SET ^(C)=^TMP($JOB,"RAMIS",D,A,"EX",C)+RAMUL
+10 FOR D=RADIV,"TOT"
SET ^(C)=^TMP($JOB,"RAMIS",D,A,"WT",C)+(RAMUL*RAWT)
+11 IF $DATA(RAOR)
FOR D=RADIV,"TOT"
SET ^(C)=^TMP($JOB,"RAMIS",D,25,"WT",C)+(RAMUL*RAWT)
+12 IF $DATA(RAPORT)
FOR D=RADIV,"TOT"
SET ^(C)=^TMP($JOB,"RAMIS",D,26,"WT",C)+(RAMUL*RAWT)
+13 IF $DATA(RAMULP)
FOR D=RADIV,"TOT"
SET ^(C)=^TMP($JOB,"RAMIS",D,"MULP","WT",C)+(RAMUL*RAWT)
+14 FOR D=RADIV,"TOT"
SET ^(C)=^TMP($JOB,"RAMIS",D,"TOT","EX",C)+RAMUL
+15 FOR D=RADIV,"TOT"
SET ^(C)=^TMP($JOB,"RAMIS",D,"TOT","WT",C)+(RAMUL*RAWT)
+16 QUIT
+17 ;
INIT ; Initialize the ^TMP($J,"RAMIS" global to zero.
+1 FOR A=1:1:27,99,"TOT","MULP"
FOR T="EX","WT"
FOR C="IN","OUT"
SET ^TMP($JOB,"RAMIS",D,A,T,C)=0
+2 FOR T="FLM","CINE","CINERUNS","VST"
FOR C="IN","OUT"
SET ^TMP($JOB,"RAMIS",D,T,C)=0
+3 QUIT
+4 ;
RAPRC IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
if $GET(ZTSTOP)=1
SET RAXIT=1
if RAXIT
QUIT
+1 IF +RAZ=25
SET RAOR=""
QUIT
+2 IF +RAZ=26
SET RAPORT=""
QUIT
+3 if $PIECE(RAZ,U,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,U,2)
SET RAMUL(J)=$SELECT(+$PIECE(RAZ,U,2)>0:+$PIECE(RAZ,U,2),1:1)
if $DATA(RABILAT)&(RAMUL(J)<2)
SET RAMUL(J)=RAMUL(J)*2
SET RACT(J)=$PIECE(RAZ,U,4)
if J>1
SET RAMULP=""
QUIT
+4 KILL RABILAT
+5 QUIT
+6 ;
FLM IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
if $GET(ZTSTOP)=1
SET RAXIT=1
if RAXIT
QUIT
+1 FOR D=RADIV,"TOT"
SET ^(C)=^TMP($JOB,"RAMIS",D,T,C)+X
if T="CINE"
SET ^(C)=^TMP($JOB,"RAMIS",D,"CINERUNS",C)+1
+2 QUIT
SHOWSTAT ;
+1 KILL ^TMP($JOB,"RA I-TYPE")
NEW RA2,RAXIT
SET (RA2,RAXIT)=""
+2 FOR
SET RA2=$ORDER(^RA(72,"AA",RA2))
if RA2=""
QUIT
SET ^TMP($JOB,"RA I-TYPE",RA2)=""
+3 DO DISPXAM^RALWKL1(8)
KILL ^TMP($JOB,"RA I-TYPE")
+4 QUIT
