- RAFLM1 ;HISC/GJC-Radiology Film Usage Report ;4/22/97 12:22
- ;;5.0;Radiology/Nuclear Medicine;**10**;Mar 16, 1998
- ; count & store in tmp global
- RADTI ;
- F RADTI=0:0 S RADTI=$O(^RADPT("AR",RADTE,RADFN,RADTI)) Q:RADTI'>0 I $D(^RADPT(RADFN,"DT",RADTI,0)) S RAD0=^(0) D RACNI Q:RAEOS
- Q
- RACNI S RADIV=$P($G(^RA(79,+$P(RAD0,U,3),0)),U),RADIV=$S($D(^DIC(4,+RADIV,0)):+RADIV,1:99)
- Q:'$D(^TMP($J,"RA",RADIV))
- F RACNI=0:0 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 I $D(^(RACNI,0)) S RAP0=^(0),RAPIFN=+$P(RAP0,"^",2) I $D(RACRT(+$P(RAP0,"^",3))) D ITNAME^RAWKL1 I RAITYPE?3AP1"-".N D CHK Q:RAEOS
- Q
- ;
- CHK Q:'$D(^TMP($J,"RA",RADIV,RAITYPE))
- 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,RAPIFN,0)) S RAPRI=^(0),RAPRC=$$LJ^XLFSTR($E($P(RAPRI,"^"),1,27),29," ") D CPT^RAFLM Q:'$D(^RAMIS(71,RAPIFN,2))
- F I=0:0 S I=$O(^RAMIS(71,RAPIFN,2,I)) Q:I'>0 I $D(^(I,0)) S RAZ=^(0),RAMJ=$S($D(^RAMIS(71.1,+RAZ,0)):^(0),1:"") D PRC
- Q:'$D(RAMIS(1)) S RAMUL=$S(J=1:RAMUL(1),1:1),RAMIS=RAMIS(1)
- FLM F I=0:0 S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"F",I)) Q:I'>0 D Q:RAEOS
- . Q:$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"F",I,0))']""
- . S RANUM=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"F",I,0))
- . Q:$D(^RA(78.4,"AW",1,+RANUM)) ;Quit if a wasted piece of film
- . S RAFLM=$S($D(^RA(78.4,+RANUM,0)):^(0),1:"UNKNOWN")
- . S:$P(RAFLM,U,2)="Y" RACINE=""
- . S RANUM=+$P(RANUM,U,2),RAFLM=$P(RAFLM,U)
- . I RAINPUT=0,'$D(^TMP($J,"RAFILM",RAFLM)) K RACINE Q
- . D:RANUM STORE
- . K RACINE
- . Q
- K RAMIS,RAMUL,RAZ,RAMJ,RAMULP,RAMULPFL
- Q
- ;
- STORE ; Store the data into ^TMP($J,"RA", by division )
- I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAEOS=1 Q:RAEOS
- I $D(RAOR) S A=25 D AUX ;If operating room
- I $D(RAPORT) S A=26 D AUX ;If portable
- I $D(RAMULP) S A="MULP" D AUX ;If modifier
- S:'$D(^TMP($J,"RA",RADIV,RAITYPE,RAFLM,RAMIS,RAPRC)) ^(RAPRC)="0^0^"_$S($P(RAPRI,"^",6)="S":"*",1:"") S X=^(RAPRC),$P(^(RAPRC),"^",1,2)=($P(X,"^")+RAMUL)_"^"_($P(X,"^",2)+RANUM)
- I '$D(RACINE) S X=^TMP($J,"RA",RADIV),$P(^(RADIV),"^",1,2)=($P(X,"^")+RAMUL)_"^"_($P(X,"^",2)+RANUM)
- I '$D(RACINE) S X=^TMP($J,"RA",RADIV,RAITYPE),$P(^(RAITYPE),"^",1,2)=($P(X,"^")+RAMUL)_"^"_($P(X,"^",2)+RANUM)
- S:'($D(^TMP($J,"RA",RADIV,RAITYPE,RAFLM))#2) ^(RAFLM)="0^0^^"_$S($D(RACINE):1,1:"") S X=^(RAFLM),$P(^(RAFLM),"^",1,2)=($P(X,"^")+RAMUL)_"^"_($P(X,"^",2)+RANUM)
- Q
- ;
- PRC I +RAZ=25 S RAOR="" Q
- I +RAZ=26 S RAPORT="" Q
- S:$P(RAZ,"^",3)="Y" RABILAT="" F J=1:1 I '$D(RAMIS(J)) S RAMIS(J)=$S(RAMJ]"":+RAZ,1:99),RAMUL(J)=$S($P(RAZ,U,2)'="":+$P(RAZ,U,2),1:1) S:$D(RABILAT)&(RAMUL(J)<2) RAMUL(J)=RAMUL(J)*2 S:J>1 RAMULP="" Q
- K RABILAT
- Q
- ;
- AUX S:'$D(^TMP($J,"RA",RADIV,RAITYPE,RAFLM,A,RAPRC)) ^(RAPRC)="0^0^"_$S($P(RAPRI,"^",6)="S":"*",1:"")
- S X=^TMP($J,"RA",RADIV,RAITYPE,RAFLM,A,RAPRC),^(RAPRC)=($P(X,"^")+RAMUL)_"^"_($P(X,"^",2)+RANUM)_"^"_$P(X,"^",3)
- Q
- CPT Q:'$P(RAPRI,"^",9) S RACPT=+$P(RAPRI,"^",9)
- S RACPT=$$NAMCODE^RACPTMSC(RACPT,DT),RACPT=$P(RACPT,"^")
- Q:RACPT=""
- S RAPRC=RAPRC_"("_RACPT_")"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAFLM1 3107 printed Feb 19, 2025@00:01:27 Page 2
- RAFLM1 ;HISC/GJC-Radiology Film Usage Report ;4/22/97 12:22
- +1 ;;5.0;Radiology/Nuclear Medicine;**10**;Mar 16, 1998
- +2 ; count & store in tmp global
- RADTI ;
- +1 FOR RADTI=0:0
- SET RADTI=$ORDER(^RADPT("AR",RADTE,RADFN,RADTI))
- if RADTI'>0
- QUIT
- IF $DATA(^RADPT(RADFN,"DT",RADTI,0))
- SET RAD0=^(0)
- DO RACNI
- if RAEOS
- QUIT
- +2 QUIT
- RACNI SET RADIV=$PIECE($GET(^RA(79,+$PIECE(RAD0,U,3),0)),U)
- SET RADIV=$SELECT($DATA(^DIC(4,+RADIV,0)):+RADIV,1:99)
- +1 if '$DATA(^TMP($JOB,"RA",RADIV))
- QUIT
- +2 FOR RACNI=0:0
- SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
- if RACNI'>0
- QUIT
- IF $DATA(^(RACNI,0))
- SET RAP0=^(0)
- SET RAPIFN=+$PIECE(RAP0,"^",2)
- IF $DATA(RACRT(+$PIECE(RAP0,"^",3)))
- DO ITNAME^RAWKL1
- IF RAITYPE?3AP1"-".N
- DO CHK
- if RAEOS
- QUIT
- +3 QUIT
- +4 ;
- CHK if '$DATA(^TMP($JOB,"RA",RADIV,RAITYPE))
- QUIT
- +1 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)
- +2 if '$DATA(^RAMIS(71,RAPIFN,0))
- QUIT
- SET RAPRI=^(0)
- SET RAPRC=$$LJ^XLFSTR($EXTRACT($PIECE(RAPRI,"^"),1,27),29," ")
- DO CPT^RAFLM
- if '$DATA(^RAMIS(71,RAPIFN,2))
- QUIT
- +3 FOR I=0:0
- SET I=$ORDER(^RAMIS(71,RAPIFN,2,I))
- if I'>0
- QUIT
- IF $DATA(^(I,0))
- SET RAZ=^(0)
- SET RAMJ=$SELECT($DATA(^RAMIS(71.1,+RAZ,0)):^(0),1:"")
- DO PRC
- +4 if '$DATA(RAMIS(1))
- QUIT
- SET RAMUL=$SELECT(J=1:RAMUL(1),1:1)
- SET RAMIS=RAMIS(1)
- FLM FOR I=0:0
- SET I=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"F",I))
- if I'>0
- QUIT
- Begin DoDot:1
- +1 if $GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"F",I,0))']""
- QUIT
- +2 SET RANUM=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"F",I,0))
- +3 ;Quit if a wasted piece of film
- if $DATA(^RA(78.4,"AW",1,+RANUM))
- QUIT
- +4 SET RAFLM=$SELECT($DATA(^RA(78.4,+RANUM,0)):^(0),1:"UNKNOWN")
- +5 if $PIECE(RAFLM,U,2)="Y"
- SET RACINE=""
- +6 SET RANUM=+$PIECE(RANUM,U,2)
- SET RAFLM=$PIECE(RAFLM,U)
- +7 IF RAINPUT=0
- IF '$DATA(^TMP($JOB,"RAFILM",RAFLM))
- KILL RACINE
- QUIT
- +8 if RANUM
- DO STORE
- +9 KILL RACINE
- +10 QUIT
- End DoDot:1
- if RAEOS
- QUIT
- +11 KILL RAMIS,RAMUL,RAZ,RAMJ,RAMULP,RAMULPFL
- +12 QUIT
- +13 ;
- STORE ; Store the data into ^TMP($J,"RA", by division )
- +1 IF $DATA(ZTQUEUED)
- DO STOPCHK^RAUTL9
- if $GET(ZTSTOP)=1
- SET RAEOS=1
- if RAEOS
- QUIT
- +2 ;If operating room
- IF $DATA(RAOR)
- SET A=25
- DO AUX
- +3 ;If portable
- IF $DATA(RAPORT)
- SET A=26
- DO AUX
- +4 ;If modifier
- IF $DATA(RAMULP)
- SET A="MULP"
- DO AUX
- +5 if '$DATA(^TMP($JOB,"RA",RADIV,RAITYPE,RAFLM,RAMIS,RAPRC))
- SET ^(RAPRC)="0^0^"_$SELECT($PIECE(RAPRI,"^",6)="S":"*",1:"")
- SET X=^(RAPRC)
- SET $PIECE(^(RAPRC),"^",1,2)=($PIECE(X,"^")+RAMUL)_"^"_($PIECE(X,"^",2)+RANUM)
- +6 IF '$DATA(RACINE)
- SET X=^TMP($JOB,"RA",RADIV)
- SET $PIECE(^(RADIV),"^",1,2)=($PIECE(X,"^")+RAMUL)_"^"_($PIECE(X,"^",2)+RANUM)
- +7 IF '$DATA(RACINE)
- SET X=^TMP($JOB,"RA",RADIV,RAITYPE)
- SET $PIECE(^(RAITYPE),"^",1,2)=($PIECE(X,"^")+RAMUL)_"^"_($PIECE(X,"^",2)+RANUM)
- +8 if '($DATA(^TMP($JOB,"RA",RADIV,RAITYPE,RAFLM))#2)
- SET ^(RAFLM)="0^0^^"_$SELECT($DATA(RACINE):1,1:"")
- SET X=^(RAFLM)
- SET $PIECE(^(RAFLM),"^",1,2)=($PIECE(X,"^")+RAMUL)_"^"_($PIECE(X,"^",2)+RANUM)
- +9 QUIT
- +10 ;
- PRC IF +RAZ=25
- SET RAOR=""
- QUIT
- +1 IF +RAZ=26
- SET RAPORT=""
- QUIT
- +2 if $PIECE(RAZ,"^",3)="Y"
- SET RABILAT=""
- FOR J=1:1
- IF '$DATA(RAMIS(J))
- SET RAMIS(J)=$SELECT(RAMJ]"":+RAZ,1:99)
- SET RAMUL(J)=$SELECT($PIECE(RAZ,U,2)'="":+$PIECE(RAZ,U,2),1:1)
- if $DATA(RABILAT)&(RAMUL(J)<2)
- SET RAMUL(J)=RAMUL(J)*2
- if J>1
- SET RAMULP=""
- QUIT
- +3 KILL RABILAT
- +4 QUIT
- +5 ;
- AUX if '$DATA(^TMP($JOB,"RA",RADIV,RAITYPE,RAFLM,A,RAPRC))
- SET ^(RAPRC)="0^0^"_$SELECT($PIECE(RAPRI,"^",6)="S":"*",1:"")
- +1 SET X=^TMP($JOB,"RA",RADIV,RAITYPE,RAFLM,A,RAPRC)
- SET ^(RAPRC)=($PIECE(X,"^")+RAMUL)_"^"_($PIECE(X,"^",2)+RANUM)_"^"_$PIECE(X,"^",3)
- +2 QUIT
- CPT if '$PIECE(RAPRI,"^",9)
- QUIT
- SET RACPT=+$PIECE(RAPRI,"^",9)
- +1 SET RACPT=$$NAMCODE^RACPTMSC(RACPT,DT)
- SET RACPT=$PIECE(RACPT,"^")
- +2 if RACPT=""
- QUIT
- +3 SET RAPRC=RAPRC_"("_RACPT_")"
- +4 QUIT