- 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 Jan 18, 2025@03:38:22 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