- RAFLM ;HISC/GJC AISC/MJK,RMO-Film Usage Report ;4/17/96 10:15
- ;;5.0;Radiology/Nuclear Medicine;**10**;Mar 16, 1998
- ;
- I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) S RAPSTX=""
- ;
- SUM W !!,"Film Usage Report",!,"-----------------" K RAFL1
- ASKSUM W ! K DIR S DIR(0)="Y",DIR("A")="Do you wish only the summary report",DIR("B")="NO",DIR("?")="Enter YES for a summary report or NO for a detailed report"
- D ^DIR K DIR I $D(DIRUT) D Q^RAFLM2 Q
- S:Y=0 RAFL1=""
- K DIROUT,DIRUT,DTOUT,DUOUT
- S X=$$DIVLOC^RAUTL7() I X D Q^RAFLM2 Q
- S A="",RATITLE="Film"
- F S A=$O(RACCESS(DUZ,"DIV-IMG",A)) Q:A']"" D
- . Q:'$D(^TMP($J,"RA D-TYPE",A)) S A1=$O(^TMP($J,"RA D-TYPE",A,0))
- . Q:A1'>0 S B=""
- . F S B=$O(RACCESS(DUZ,"DIV-IMG",A,B)) Q:B']"" D
- .. I $D(^TMP($J,"RA I-TYPE",B)) D IT^RALWKL2 I B1?3AP1"-".N S ^TMP($J,"RAFLM",A1,B1)=0
- .. Q
- . Q
- K A,A1,B,B1,RACCESS(DUZ,"DIV-IMG")
- S RAINPUT=$$ALLNOTH^RALWKL3() I RAINPUT="" D Q^RAFLM2 Q
- I RAINPUT=0 D FILM I RAQUIT=1 D Q^RAFLM2 Q
- I RAINPUT=0 S RAFLDCNT=0,RALP="" F S RALP=$O(^TMP($J,"RAFILM",RALP)) Q:RALP="" S RAFLDCNT=RAFLDCNT+1
- K RALP
- D DATE^RAUTL I RAPOP D Q^RAFLM2 Q
- S RAXIT=0 D DISPXAM^RALWKL1(6) I RAXIT D Q^RAFLM2 Q
- S ZTDESC="Rad/Nuc Med FILM USAGE RPT",ZTRTN="START^RAFLM",ZTSAVE("^TMP($J,""RAFILM"",")="",ZTSAVE("^TMP($J,""RAFLM"",")="" S:$D(RAFL1) ZTSAVE("RAFL1")=""
- F RASV="BEGDATE","ENDDATE","RAFLDCNT","RAINPUT" S ZTSAVE(RASV)=""
- DEV W ! D ZIS^RAUTL I RAPOP D Q^RAFLM2 Q
- START ; start processing
- U IO K ^TMP($J,"RA") S RABEG=BEGDATE-.0001,RAEND=ENDDATE+.9999,RACRT=6 D CRIT^RAUTL1 S RACPT=""
- S:$D(ZTQUEUED) ZTREQ="@"
- S RAITCNT=0,RALP="",RAEOS=0
- F S RALP=$O(^TMP($J,"RAFLM",RALP)) Q:RALP="" S RAITCNT(RALP)=0,^TMP($J,"RA",RALP)="0^0" S RALP1="" F S RALP1=$O(^TMP($J,"RAFLM",RALP,RALP1)) Q:RALP1="" S RAITCNT(RALP)=RAITCNT(RALP)+1,^TMP($J,"RA",RALP,RALP1)="0^0"
- K RALP,RALP1
- F RADTE=RABEG:0:RAEND S RADTE=$O(^RADPT("AR",RADTE)) Q:RADTE'>0!(RADTE>RAEND)!(RAEOS) F RADFN=0:0 S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:RADFN'>0 D RADTI^RAFLM1 Q:RAEOS
- G:'RAEOS ^RAFLM2
- Q
- FILM ; select films to include in report
- K ^TMP($J,"RAFILM")
- S RAONECHK=$P(^RA(78.4,0),U,4) I RAONECHK=1 S RAIEN=$O(^RA(78.4,0)) Q:RAIEN<1 S RAONENME=$P(^RA(78.4,+RAIEN,0),U,1),RAONENME=$E(RAONENME,1,30),^TMP($J,"RAFILM",RAONENME)="" D KILL Q
- S RADIC="^RA(78.4,",RADIC(0)="QEAMZ",RADIC("A")="Select "_RATITLE_": ",RAUTIL="RAFILM"
- S RADIC("S")="I '$P(^(0),U,4)"
- D EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT)
- KILL ;
- K %W,%Y1,DIC,RACNT,RADIC,RAIEN,RAONECHK,RAONENME,RAUTIL,X,Y
- 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[HRAFLM 2723 printed Feb 19, 2025@00:01:26 Page 2
- RAFLM ;HISC/GJC AISC/MJK,RMO-Film Usage Report ;4/17/96 10:15
- +1 ;;5.0;Radiology/Nuclear Medicine;**10**;Mar 16, 1998
- +2 ;
- +3 IF $ORDER(RACCESS(DUZ,""))=""
- DO SETVARS^RAPSET1(0)
- SET RAPSTX=""
- +4 ;
- SUM WRITE !!,"Film Usage Report",!,"-----------------"
- KILL RAFL1
- ASKSUM WRITE !
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Do you wish only the summary report"
- SET DIR("B")="NO"
- SET DIR("?")="Enter YES for a summary report or NO for a detailed report"
- +1 DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- DO Q^RAFLM2
- QUIT
- +2 if Y=0
- SET RAFL1=""
- +3 KILL DIROUT,DIRUT,DTOUT,DUOUT
- +4 SET X=$$DIVLOC^RAUTL7()
- IF X
- DO Q^RAFLM2
- QUIT
- +5 SET A=""
- SET RATITLE="Film"
- +6 FOR
- SET A=$ORDER(RACCESS(DUZ,"DIV-IMG",A))
- if A']""
- QUIT
- Begin DoDot:1
- +7 if '$DATA(^TMP($JOB,"RA D-TYPE",A))
- QUIT
- SET A1=$ORDER(^TMP($JOB,"RA D-TYPE",A,0))
- +8 if A1'>0
- QUIT
- SET B=""
- +9 FOR
- SET B=$ORDER(RACCESS(DUZ,"DIV-IMG",A,B))
- if B']""
- QUIT
- Begin DoDot:2
- +10 IF $DATA(^TMP($JOB,"RA I-TYPE",B))
- DO IT^RALWKL2
- IF B1?3AP1"-".N
- SET ^TMP($JOB,"RAFLM",A1,B1)=0
- +11 QUIT
- End DoDot:2
- +12 QUIT
- End DoDot:1
- +13 KILL A,A1,B,B1,RACCESS(DUZ,"DIV-IMG")
- +14 SET RAINPUT=$$ALLNOTH^RALWKL3()
- IF RAINPUT=""
- DO Q^RAFLM2
- QUIT
- +15 IF RAINPUT=0
- DO FILM
- IF RAQUIT=1
- DO Q^RAFLM2
- QUIT
- +16 IF RAINPUT=0
- SET RAFLDCNT=0
- SET RALP=""
- FOR
- SET RALP=$ORDER(^TMP($JOB,"RAFILM",RALP))
- if RALP=""
- QUIT
- SET RAFLDCNT=RAFLDCNT+1
- +17 KILL RALP
- +18 DO DATE^RAUTL
- IF RAPOP
- DO Q^RAFLM2
- QUIT
- +19 SET RAXIT=0
- DO DISPXAM^RALWKL1(6)
- IF RAXIT
- DO Q^RAFLM2
- QUIT
- +20 SET ZTDESC="Rad/Nuc Med FILM USAGE RPT"
- SET ZTRTN="START^RAFLM"
- SET ZTSAVE("^TMP($J,""RAFILM"",")=""
- SET ZTSAVE("^TMP($J,""RAFLM"",")=""
- if $DATA(RAFL1)
- SET ZTSAVE("RAFL1")=""
- +21 FOR RASV="BEGDATE","ENDDATE","RAFLDCNT","RAINPUT"
- SET ZTSAVE(RASV)=""
- DEV WRITE !
- DO ZIS^RAUTL
- IF RAPOP
- DO Q^RAFLM2
- QUIT
- START ; start processing
- +1 USE IO
- KILL ^TMP($JOB,"RA")
- SET RABEG=BEGDATE-.0001
- SET RAEND=ENDDATE+.9999
- SET RACRT=6
- DO CRIT^RAUTL1
- SET RACPT=""
- +2 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +3 SET RAITCNT=0
- SET RALP=""
- SET RAEOS=0
- +4 FOR
- SET RALP=$ORDER(^TMP($JOB,"RAFLM",RALP))
- if RALP=""
- QUIT
- SET RAITCNT(RALP)=0
- SET ^TMP($JOB,"RA",RALP)="0^0"
- SET RALP1=""
- FOR
- SET RALP1=$ORDER(^TMP($JOB,"RAFLM",RALP,RALP1))
- if RALP1=""
- QUIT
- SET RAITCNT(RALP)=RAITCNT(RALP)+1
- SET ^TMP($JOB,"RA",RALP,RALP1)="0^0"
- +5 KILL RALP,RALP1
- +6 FOR RADTE=RABEG:0:RAEND
- SET RADTE=$ORDER(^RADPT("AR",RADTE))
- if RADTE'>0!(RADTE>RAEND)!(RAEOS)
- QUIT
- FOR RADFN=0:0
- SET RADFN=$ORDER(^RADPT("AR",RADTE,RADFN))
- if RADFN'>0
- QUIT
- DO RADTI^RAFLM1
- if RAEOS
- QUIT
- +7 if 'RAEOS
- GOTO ^RAFLM2
- +8 QUIT
- FILM ; select films to include in report
- +1 KILL ^TMP($JOB,"RAFILM")
- +2 SET RAONECHK=$PIECE(^RA(78.4,0),U,4)
- IF RAONECHK=1
- SET RAIEN=$ORDER(^RA(78.4,0))
- if RAIEN<1
- QUIT
- SET RAONENME=$PIECE(^RA(78.4,+RAIEN,0),U,1)
- SET RAONENME=$EXTRACT(RAONENME,1,30)
- SET ^TMP($JOB,"RAFILM",RAONENME)=""
- DO KILL
- QUIT
- +3 SET RADIC="^RA(78.4,"
- SET RADIC(0)="QEAMZ"
- SET RADIC("A")="Select "_RATITLE_": "
- SET RAUTIL="RAFILM"
- +4 SET RADIC("S")="I '$P(^(0),U,4)"
- +5 DO EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT)
- KILL ;
- +1 KILL %W,%Y1,DIC,RACNT,RADIC,RAIEN,RAONECHK,RAONENME,RAUTIL,X,Y
- +2 QUIT
- CPT ;
- +1 if '$PIECE(RAPRI,"^",9)
- QUIT
- SET RACPT=+$PIECE(RAPRI,"^",9)
- +2 SET RACPT=$$NAMCODE^RACPTMSC(RACPT,DT)
- SET RACPT=$PIECE(RACPT,"^")
- +3 if RACPT=""
- QUIT
- +4 SET RAPRC=RAPRC_"("_RACPT_")"
- +5 QUIT