- RAOUT ;HISC/CAH,FPT,GJC AISC/TMP,RMO-Outside Film Option ;9/12/94 11:13
- ;;5.0;Radiology/Nuclear Medicine;**31**;Mar 16, 1998
- 1 ;;Add Films to Registry
- D SET^RAPSET1 I $D(XQUIT) K XQUIT Q
- S DIC(0)="AEMQL" D ^RADPA K DIC G Q1:Y<0 S (RADFN,DA)=+Y,DIE="^RADPT(",DR="[RA OUTSIDE ADD]" D ^DIE K DE,DQ,DIE,DR D Q1 W ! G 1
- Q1 K %,%DT,%W,%Y,%Y1,A,C,D,D0,D1,D2,DA,DDER,DDH,DI,RADFN,RAPTFL,X,Y Q
- ;
- 2 ;;Edit Registry
- D SET^RAPSET1 I $D(XQUIT) K XQUIT Q
- S DIC(0)="AEMQ" D ^RADPA K DIC G Q2:Y<0 S (RADFN,DA)=+Y,DIE="^RADPT(",DR="[RA OUTSIDE EDIT]" D ^DIE K DA,DI,DIE,DQ,DR D Q2 W ! G 2
- Q2 K %,%DT,%DUZ,%W,%X,%Y,%Y1,C,D,D0,D1,D2,DA,DDER,DIE,DR,RADFN,X,Y Q
- ;
- 3 ;;Flag Film to Need 'OK' Before Return
- D SET^RAPSET1 I $D(XQUIT) K XQUIT Q
- S DIC(0)="AEMQ" D ^RADPA K DIC G Q3:Y<0 S (RADFN,DA)=+Y,DIE="^RADPT(",DR="[RA OUTSIDE SUPEROK]" D ^DIE K DA,DI,DIE,DQ,DR D Q3 W ! G 3
- Q3 K %,%DT,%DUZ,%W,%X,%Y,%Y1,C,D,D0,D1,D2,DA,DDER,DIE,DR,I,RADFN,X,Y Q
- ;
- 4 ;;Delinquent Outside Film Report for Outpatients
- S %DT("A")="All Films with 'Needed Back' Dates Less Than: ",%DT="AEX" D ^%DT K %DT Q:Y<0
- S DIC="^RADPT(",L=0,TO=Y,FLDS="[RA OUTSIDE LIST]",BY="[RA OUTSIDE LIST]",DIS(0)="I '$D(^DPT(D0,.1))",FR=2000101 G EN1^DIP
- ;
- 5 ;;Outside Films Profile
- S DIC(0)="AEMQ" D ^RADPA K DIC G Q5:Y<0 S RALL=1,RADFN=+Y
- PROF S ZTRTN="START^RAOUT",ZTSAVE("RADFN")="",ZTSAVE("RALL")="" D ZIS^RAUTL K IOP G Q5:RAPOP
- START G Q5:'$D(^DPT(RADFN,0)) S RANME=^(0),RASSN=$$SSN^RAUTL,RANME=$P(RANME,"^")
- U IO S RAPG=0 D HD I '$D(^RADPT(RADFN,"O")) W !!,"No outside films have been registered for this patient." G Q5
- F RAI=0:0 S RAI=$O(^RADPT(RADFN,"O",RAI)) Q:RAI'>0 I $D(^(RAI,0)) S Y=^(0) I RALL!('$P(Y,"^",3))!($P(Y,"^",3)>DT) D PRT
- Q5 K C,I,J,POP,RAPG,RAPOP,RAI,RADFN,RALL,RASSN,RANME,X,Y D CLOSE^RAUTL ;Q
- K RAMES Q
- PRT W !,"Registered: ",$E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3),?30,"Returned : ",$S($P(Y,"^",3):$E($P(Y,"^",3),4,5)_"/"_$E($P(Y,"^",3),6,7)_"/"_$E($P(Y,"^",3),2,3),1:"still on file"),?60,"'OK' Needed: ",$S($P(Y,"^",5)="Y":"Yes",1:"No")
- W !,"Source : ",$P(Y,"^",4) I $D(^RADPT(RADFN,"O",RAI,1)) S X=^(1) D REM
- W !,I
- I ($Y+5)>IOSL,IO=IO(0) R !,"Press RETURN to continue. ",X:DTIME D HD
- Q
- REM F J=1:60:240 S Y=$E(X,J,J+60) Q:Y']"" W !,$S(J=1:"Remarks : ",1:""),?12,Y
- Q
- ;
- HD ; Header
- S RAPG=RAPG+1 W:$E(IOST,1,2)="C-" @IOF
- I $E(IOST,1,2)="P-",(RAPG>1) W @IOF
- W "Patient: ",RANME," ",RASSN,?55,"Run Date: " S Y=DT D DT^DIO2
- W !!?15,"***** Outside Films Profile *****",$S(RALL=0:" (Films NOT Returned only)",1:"") W ! S I="",$P(I,"-",80)="" W I
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAOUT 2588 printed Jan 18, 2025@03:39:27 Page 2
- RAOUT ;HISC/CAH,FPT,GJC AISC/TMP,RMO-Outside Film Option ;9/12/94 11:13
- +1 ;;5.0;Radiology/Nuclear Medicine;**31**;Mar 16, 1998
- 1 ;;Add Films to Registry
- +1 DO SET^RAPSET1
- IF $DATA(XQUIT)
- KILL XQUIT
- QUIT
- +2 SET DIC(0)="AEMQL"
- DO ^RADPA
- KILL DIC
- if Y<0
- GOTO Q1
- SET (RADFN,DA)=+Y
- SET DIE="^RADPT("
- SET DR="[RA OUTSIDE ADD]"
- DO ^DIE
- KILL DE,DQ,DIE,DR
- DO Q1
- WRITE !
- GOTO 1
- Q1 KILL %,%DT,%W,%Y,%Y1,A,C,D,D0,D1,D2,DA,DDER,DDH,DI,RADFN,RAPTFL,X,Y
- QUIT
- +1 ;
- 2 ;;Edit Registry
- +1 DO SET^RAPSET1
- IF $DATA(XQUIT)
- KILL XQUIT
- QUIT
- +2 SET DIC(0)="AEMQ"
- DO ^RADPA
- KILL DIC
- if Y<0
- GOTO Q2
- SET (RADFN,DA)=+Y
- SET DIE="^RADPT("
- SET DR="[RA OUTSIDE EDIT]"
- DO ^DIE
- KILL DA,DI,DIE,DQ,DR
- DO Q2
- WRITE !
- GOTO 2
- Q2 KILL %,%DT,%DUZ,%W,%X,%Y,%Y1,C,D,D0,D1,D2,DA,DDER,DIE,DR,RADFN,X,Y
- QUIT
- +1 ;
- 3 ;;Flag Film to Need 'OK' Before Return
- +1 DO SET^RAPSET1
- IF $DATA(XQUIT)
- KILL XQUIT
- QUIT
- +2 SET DIC(0)="AEMQ"
- DO ^RADPA
- KILL DIC
- if Y<0
- GOTO Q3
- SET (RADFN,DA)=+Y
- SET DIE="^RADPT("
- SET DR="[RA OUTSIDE SUPEROK]"
- DO ^DIE
- KILL DA,DI,DIE,DQ,DR
- DO Q3
- WRITE !
- GOTO 3
- Q3 KILL %,%DT,%DUZ,%W,%X,%Y,%Y1,C,D,D0,D1,D2,DA,DDER,DIE,DR,I,RADFN,X,Y
- QUIT
- +1 ;
- 4 ;;Delinquent Outside Film Report for Outpatients
- +1 SET %DT("A")="All Films with 'Needed Back' Dates Less Than: "
- SET %DT="AEX"
- DO ^%DT
- KILL %DT
- if Y<0
- QUIT
- +2 SET DIC="^RADPT("
- SET L=0
- SET TO=Y
- SET FLDS="[RA OUTSIDE LIST]"
- SET BY="[RA OUTSIDE LIST]"
- SET DIS(0)="I '$D(^DPT(D0,.1))"
- SET FR=2000101
- GOTO EN1^DIP
- +3 ;
- 5 ;;Outside Films Profile
- +1 SET DIC(0)="AEMQ"
- DO ^RADPA
- KILL DIC
- if Y<0
- GOTO Q5
- SET RALL=1
- SET RADFN=+Y
- PROF SET ZTRTN="START^RAOUT"
- SET ZTSAVE("RADFN")=""
- SET ZTSAVE("RALL")=""
- DO ZIS^RAUTL
- KILL IOP
- if RAPOP
- GOTO Q5
- START if '$DATA(^DPT(RADFN,0))
- GOTO Q5
- SET RANME=^(0)
- SET RASSN=$$SSN^RAUTL
- SET RANME=$PIECE(RANME,"^")
- +1 USE IO
- SET RAPG=0
- DO HD
- IF '$DATA(^RADPT(RADFN,"O"))
- WRITE !!,"No outside films have been registered for this patient."
- GOTO Q5
- +2 FOR RAI=0:0
- SET RAI=$ORDER(^RADPT(RADFN,"O",RAI))
- if RAI'>0
- QUIT
- IF $DATA(^(RAI,0))
- SET Y=^(0)
- IF RALL!('$PIECE(Y,"^",3))!($PIECE(Y,"^",3)>DT)
- DO PRT
- Q5 ;Q
- KILL C,I,J,POP,RAPG,RAPOP,RAI,RADFN,RALL,RASSN,RANME,X,Y
- DO CLOSE^RAUTL
- +1 KILL RAMES
- QUIT
- PRT WRITE !,"Registered: ",$EXTRACT(Y,4,5),"/",$EXTRACT(Y,6,7),"/",$EXTRACT(Y,2,3),?30,"Returned : ",$SELECT(...
- ... $PIECE(Y,"^",3):$EXTRACT($PIECE(Y,"^",3),4,5)_"/"_$EXTRACT($PIECE(Y,"^",3),6,7)_"/"_$EXTRACT($PIECE(Y,"^",3),2,3),1:"still on file"),?60,"'OK' Needed: ",$SELECT($PIECE(Y,"^",5)="Y":"Yes",1:"No")
- +1 WRITE !,"Source : ",$PIECE(Y,"^",4)
- IF $DATA(^RADPT(RADFN,"O",RAI,1))
- SET X=^(1)
- DO REM
- +2 WRITE !,I
- +3 IF ($Y+5)>IOSL
- IF IO=IO(0)
- READ !,"Press RETURN to continue. ",X:DTIME
- DO HD
- +4 QUIT
- REM FOR J=1:60:240
- SET Y=$EXTRACT(X,J,J+60)
- if Y']""
- QUIT
- WRITE !,$SELECT(J=1:"Remarks : ",1:""),?12,Y
- +1 QUIT
- +2 ;
- HD ; Header
- +1 SET RAPG=RAPG+1
- if $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- +2 IF $EXTRACT(IOST,1,2)="P-"
- IF (RAPG>1)
- WRITE @IOF
- +3 WRITE "Patient: ",RANME," ",RASSN,?55,"Run Date: "
- SET Y=DT
- DO DT^DIO2
- +4 WRITE !!?15,"***** Outside Films Profile *****",$SELECT(RALL=0:" (Films NOT Returned only)",1:"")
- WRITE !
- SET I=""
- SET $PIECE(I,"-",80)=""
- WRITE I
- +5 QUIT