RARTST2 ;HISC/CAH,FPT,GJC,DAD AISC/MJK,RMO-Reports Distribution ;3/19/97 13:45
;;5.0;Radiology/Nuclear Medicine;**8,9**;Mar 16, 1998
SRT N RASRT S RASRT="" F RAS2=0:0 S RASRT=$O(^TMP($J,"RADIST",RABTY,RASRT)) Q:RASRT="" F RAR=0:0 S RAR=$O(^TMP($J,"RADIST",RABTY,RASRT,RAR)) Q:'RAR S RARDIFN=+^(RAR) D PRNT
Q
SET S RARPT=+Y K RABTY D RASET^RAUTL2 Q:'Y S RAY3=$G(^RABTCH(74.4,RARDIFN,0)) Q:RAY3']""
I $D(^RABTCH(74.3,"B","REQUESTING PHYSICIAN",RAB))#2 D G SET1
. ; Requesting Physician functionality
. S:+$P(RAY3,"^",12) RABTY=$P($G(^VA(200,+$P(RAY3,"^",12),0)),"^")
. S:'+$P(RAY3,"^",12) RABTY=$P($G(^VA(200,+$P(Y,"^",14),0)),"^")
. S:RABTY']"" RABTY="Unknown" S RABTY="^"_RABTY
. Q
I RABT=6!(RABT=8) D Q:'$D(RABTY)
. S Y=+$P(RAY3,"^",RABT) Q:'Y
. I RABT=6,$D(^DIC(42,Y,0)) S RABTY=$P(^(0),"^")
. I RABT=8,$D(^SC(Y,0)) S RABTY=$P(^(0),"^")
. Q
E D
. N RA6,RA8 S RABTY="Unknown"
. S RA6=+$P(RAY3,"^",6),RA8=+$P(RAY3,"^",8)
. I RA6,'RA8 S RABTY=$S($D(^DIC(42,RA6,0)):$P(^(0),"^"),1:RABTY)
. I 'RA6,RA8 S RABTY=$S($D(^SC(RA8,0)):$P(^(0),"^"),1:RABTY)
. S:RABTY']"" RABTY="Unknown"
. Q
;
SET1 ; Set the data global
N RAEXIT S RAEXIT=0
S RAY1=$G(^RADPT(RADFN,"DT",RADTI,0)) Q:'$D(RAIMAG(+$P(RAY1,U,2))) I $D(RANGE),$P(RAY3,"^",+$P(RANGE,"^",3))'=+RANGE Q
;If RANGE is defined, user is prt'g from 'Individual Ward' or 'Single
; Clinic' option, and rpt should be bypassed if ward or clinic on the
; file 74.3 rpt record does not one of the selected requesting loc's
;If RANGE is NOT defined, user is prt'g from 'Print by Routine Queue'
; option and bypass logic depends on which queue they are printing
; from: If Requesting Phys. Queue, use requesting location (i.e. ward
; or clinic on file 74.3) to determine if its division matches the
; division selected. If File Room, Medical Records, or Other than
; Ward or Clinic queues are being printed, use exam division (i.e.
; division on exam record) to determine if exam's division matches
; the division selected.
I '$D(RANGE),$D(^RABTCH(74.3,"B","REQUESTING PHYSICIAN",RAB)) D Q:RAEXIT
. I $P(RAY3,"^",6) S:'$D(RAF408($$GET1^DIQ(42,$P(RAY3,"^",6),.015,"I"))) RAEXIT=1
. I $P(RAY3,"^",8) S:'$D(RAF408($$GET1^DIQ(44,$P(RAY3,"^",8),3.5,"I"))) RAEXIT=1
. Q
I '$D(RANGE),('$D(^RABTCH(74.3,"B","REQUESTING PHYSICIAN",RAB))) Q:'$D(RA4(+$P(RAY1,"^",3)))
Q:'$D(^DPT(RADFN,0)) S RANME=^(0),RASSN=$$SSN^RAUTL,RASSN=$S(RASSN:$TR(RASSN,"-"),1:"999999999"),RANME=$P(RANME,"^")
S RARTST2=1 D UPDLOC^RAUTL10 K RARTST2 Q:'$D(RAPRTOK)
;RARTST2I will only be defined if UPDLOC has deleted the file 74.4
;entry RARDIFN. RARTST2I will be the modified File Room entry
;S ^TMP($J,"RADIST",$S(RALOCSRT=1:RABTY,1:U),$S(RASRT="P":RANME,RASRT="S":"A"_RASSN,RASRT="T":"A"_($E(RASSN,8,9)_$E(RASSN,6,7))),RARPT)=$S($D(RARTST2I):RARTST2I,1:RARDIFN) K RARTST2I
S ^TMP($J,"RADIST",$S(RALOCSRT=1:RABTY,1:U),$S(RASRT="P":RANME,RASRT="S":"A"_RASSN,RASRT="T":"A"_($$HRCNT^BDGF2(RASSN))),RARPT)=$S($D(RARTST2I):RARTST2I,1:RARDIFN) K RARTST2I ;IHS/ITSC/CLS 10/22/2003
; use IHS health record number terminal digit order
Q
;
PRNT Q:'$D(^RARPT(RAR,0)) Q:$P(^(0),"^",5)'="V" S:$D(^RABTCH(74.3,RAB,"M")) RARTMES=^("M")_$S($D(RABEG):" (REPRINT)",1:"")
S RASTFL="" S RARPT=RAR D ^RARTR Q:$G(RAY3)<0
S %DT="TX",X="NOW" D ^%DT
I $D(^RABTCH(74.4,RARDIFN,0)),($P(^RABTCH(74.4,RARDIFN,0),"^",4)="") D
. N D,D0,DA,DI,DIC,DIE,DQ,DR,X
. S DA=RARDIFN,DIE="^RABTCH(74.4,"
. S DR="3////"_DUZ_";4////"_Y D ^DIE
. Q
S RARTCNT=RARTCNT+1 Q
;
START ;RANGE is only defined if prt'g via 'Individual Ward' or 'Single Clinic'
;options. The next ward or clinic to be printed is saved in piece
;1 and 2 of RANGE (RANGE=ward or clinic ien^ward or clinic name^6 or 8)
U IO
I $D(RANGE) D
. S TEXT="",RANGE=$TR(RANGE,"~","^")
. F S TEXT=$O(^TMP($J,"WARD/CLIN",TEXT)) Q:TEXT="" D
.. S TEXTD0=0
.. F S TEXTD0=$O(^TMP($J,"WARD/CLIN",TEXT,TEXTD0)) Q:TEXTD0'>0 D
... S $P(RANGE,U,1,2)=TEXTD0_U_TEXT D START0
... Q
.. Q
. Q
E D
. D START0
. Q
K %DT,D0,D1,DA,DIC,DIE,DIR,DIRUT,DIWF,DIWL,DIWR,DR,POP,RABT,RABTY,RACNI
K RADATE,RAIMAG,RAPRT,RAPRTF,RAPRTOK,RAST,Z,RARTMES,RARPT,RARTCNT,RAB
K RARDIFN,RADIV,RASRT,RABEG,RAEND,RAR,RASSN,RANME,RADFN,RADT,RADTI
K RANGE,RARPT,RAS1,RAS2,RASTFL,RALOCSRT,RARTST1,RAY1,TEXT,TEXTD0
K ^TMP($J,"RADIST"),^TMP($J,"WARD/CLIN")
D CLOSE^RAUTL
Q
;
START0 ;
K ^TMP($J,"RADIST") Q:'$D(^RABTCH(74.3,RAB,0)) S Y=$P(^(0),"^",2),RABT=$S(Y="I":6,Y="O":8,1:0),RAPRTF=1 D BANNER
I '$D(RABEG) F RARDIFN=0:0 S RARDIFN=$O(^RABTCH(74.4,"C",RAB,RARDIFN)) Q:'RARDIFN I $D(^RABTCH(74.4,RARDIFN,0)),'$P(^(0),"^",4) S Y=^(0) D SET
I $D(RABEG) F RADT=(RABEG-.0001):0 S RADT=$O(^RABTCH(74.4,"AD",RADT)) Q:'RADT!(RADT>RAEND) F RARDIFN=0:0 S RARDIFN=$O(^RABTCH(74.4,"AD",RADT,RARDIFN)) Q:'RARDIFN I $D(^RABTCH(74.4,RARDIFN,0)),$P(^(0),"^",11)=RAB S Y=^(0) D SET
I '$D(^TMP($J,"RADIST")) D G Q
. W:$Y>(IOSL-4) @IOF
. W !!,$G(RARTMES),!!,"No reports met the criteria selected."
. I $D(RANGE) W !,$P("^^^^^Ward^^Clinic",U,$P(RANGE,U,3)),": ",$P(RANGE,U,2)
. Q
S RABTY="",RARTCNT=0 F RAS1=0:0 S RABTY=$O(^TMP($J,"RADIST",RABTY)) Q:RABTY="" D NEWLOC,SRT
W @IOF,"Total Number of Reports printed: ",RARTCNT,!!
;S DA=+RAB,DR="[RA DISTRIBUTION LOG]",DIE="^RABTCH(74.3,",RARTMES="" S:$D(RANGE) RARTMES=$P(RANGE,"^",2)
;D ^DIE K DE,DQ
; Added in patch 9 to stop endless loops...
START1 L +^RABATCH(74.3,+RAB)
S RARTMES="" S:$D(RANGE) RARTMES=$P(RANGE,U,2)
S RAIENS="+1,"_(+RAB)_",",RAFDA(74.33,RAIENS,.01)="NOW"
D UPDATE^DIE("E","RAFDA","RAIEN","RAERR")
I '$G(RAIEN(1)) L -^RABTCH(74.3,+RAB) K RAIENS,RAIEN,RAFDA G START1
K RAFDA,RAIENS S RAIENS=RAIEN(1)_","_(+RAB)_"," K RAIEN
S RAFDA(74.33,RAIENS,2)=$S($D(RABEG):"R",1:"P")
S RAFDA(74.33,RAIENS,3)=DUZ
S RAFDA(74.33,RAIENS,4)=$E(RARTMES,1,20)
S RAFDA(74.33,RAIENS,5)=RARTCNT
D FILE^DIE(,"RAFDA","RAERR")
L -^RABTCH(74.3,+RAB)
K RAFDA,RAIENS,RAERR
Q D BANNER
Q
;
BANNER I $D(^RABTCH(74.3,RAB,"M")) S RARTMES=^("M")_$S($D(RABEG):" (REPRINT)",1:"")
Q
NEWLOC ; Print Location/Requesting Physician data
I RABTY="^" Q
W @IOF,!!!!!?10
W $S(RABTY'["^":"L O C A T I O N : ",1:"REQUESTING PHYSICIAN: ")
W $S(RABTY["^":$P(RABTY,"^",2),1:RABTY)
Q
RARTST2 ;HISC/CAH,FPT,GJC,DAD AISC/MJK,RMO-Reports Distribution ;3/19/97 13:45
+1 ;;5.0;Radiology/Nuclear Medicine;**8,9**;Mar 16, 1998
SRT NEW RASRT
SET RASRT=""
FOR RAS2=0:0
SET RASRT=$ORDER(^TMP($JOB,"RADIST",RABTY,RASRT))
IF RASRT=""
QUIT
FOR RAR=0:0
SET RAR=$ORDER(^TMP($JOB,"RADIST",RABTY,RASRT,RAR))
IF 'RAR
QUIT
SET RARDIFN=+^(RAR)
DO PRNT
+1 QUIT
SET SET RARPT=+Y
KILL RABTY
DO RASET^RAUTL2
IF 'Y
QUIT
SET RAY3=$GET(^RABTCH(74.4,RARDIFN,0))
IF RAY3']""
QUIT
+1 IF $DATA(^RABTCH(74.3,"B","REQUESTING PHYSICIAN",RAB))#2
Begin DoDot:1
+2 ; Requesting Physician functionality
+3 IF +$PIECE(RAY3,"^",12)
SET RABTY=$PIECE($GET(^VA(200,+$PIECE(RAY3,"^",12),0)),"^")
+4 IF '+$PIECE(RAY3,"^",12)
SET RABTY=$PIECE($GET(^VA(200,+$PIECE(Y,"^",14),0)),"^")
+5 IF RABTY']""
SET RABTY="Unknown"
SET RABTY="^"_RABTY
+6 QUIT
End DoDot:1
GOTO SET1
+7 IF RABT=6!(RABT=8)
Begin DoDot:1
+8 SET Y=+$PIECE(RAY3,"^",RABT)
IF 'Y
QUIT
+9 IF RABT=6
IF $DATA(^DIC(42,Y,0))
SET RABTY=$PIECE(^(0),"^")
+10 IF RABT=8
IF $DATA(^SC(Y,0))
SET RABTY=$PIECE(^(0),"^")
+11 QUIT
End DoDot:1
IF '$DATA(RABTY)
QUIT
+12 IF '$TEST
Begin DoDot:1
+13 NEW RA6,RA8
SET RABTY="Unknown"
+14 SET RA6=+$PIECE(RAY3,"^",6)
SET RA8=+$PIECE(RAY3,"^",8)
+15 IF RA6
IF 'RA8
SET RABTY=$SELECT($DATA(^DIC(42,RA6,0)):$PIECE(^(0),"^"),1:RABTY)
+16 IF 'RA6
IF RA8
SET RABTY=$SELECT($DATA(^SC(RA8,0)):$PIECE(^(0),"^"),1:RABTY)
+17 IF RABTY']""
SET RABTY="Unknown"
+18 QUIT
End DoDot:1
+19 ;
SET1 ; Set the data global
+1 NEW RAEXIT
SET RAEXIT=0
+2 SET RAY1=$GET(^RADPT(RADFN,"DT",RADTI,0))
IF '$DATA(RAIMAG(+$PIECE(RAY1,U,2)))
QUIT
IF $DATA(RANGE)
IF $PIECE(RAY3,"^",+$PIECE(RANGE,"^",3))'=+RANGE
QUIT
+3 ;If RANGE is defined, user is prt'g from 'Individual Ward' or 'Single
+4 ; Clinic' option, and rpt should be bypassed if ward or clinic on the
+5 ; file 74.3 rpt record does not one of the selected requesting loc's
+6 ;If RANGE is NOT defined, user is prt'g from 'Print by Routine Queue'
+7 ; option and bypass logic depends on which queue they are printing
+8 ; from: If Requesting Phys. Queue, use requesting location (i.e. ward
+9 ; or clinic on file 74.3) to determine if its division matches the
+10 ; division selected. If File Room, Medical Records, or Other than
+11 ; Ward or Clinic queues are being printed, use exam division (i.e.
+12 ; division on exam record) to determine if exam's division matches
+13 ; the division selected.
+14 IF '$DATA(RANGE)
IF $DATA(^RABTCH(74.3,"B","REQUESTING PHYSICIAN",RAB))
Begin DoDot:1
+15 IF $PIECE(RAY3,"^",6)
IF '$DATA(RAF408($$GET1^DIQ(42,$PIECE(RAY3,"^",6),.015,"I")))
SET RAEXIT=1
+16 IF $PIECE(RAY3,"^",8)
IF '$DATA(RAF408($$GET1^DIQ(44,$PIECE(RAY3,"^",8),3.5,"I")))
SET RAEXIT=1
+17 QUIT
End DoDot:1
IF RAEXIT
QUIT
+18 IF '$DATA(RANGE)
IF ('$DATA(^RABTCH(74.3,"B","REQUESTING PHYSICIAN",RAB)))
IF '$DATA(RA4(+$PIECE(RAY1,"^",3)))
QUIT
+19 IF '$DATA(^DPT(RADFN,0))
QUIT
SET RANME=^(0)
SET RASSN=$$SSN^RAUTL
SET RASSN=$SELECT(RASSN:$TRANSLATE(RASSN,"-"),1:"999999999")
SET RANME=$PIECE(RANME,"^")
+20 SET RARTST2=1
DO UPDLOC^RAUTL10
KILL RARTST2
IF '$DATA(RAPRTOK)
QUIT
+21 ;RARTST2I will only be defined if UPDLOC has deleted the file 74.4
+22 ;entry RARDIFN. RARTST2I will be the modified File Room entry
+23 ;S ^TMP($J,"RADIST",$S(RALOCSRT=1:RABTY,1:U),$S(RASRT="P":RANME,RASRT="S":"A"_RASSN,RASRT="T":"A"_($E(RASSN,8,9)_$E(RASSN,6,7))),RARPT)=$S($D(RARTST2I):RARTST2I,1:RARDIFN) K RARTST2I
+24 ;IHS/ITSC/CLS 10/22/2003
SET ^TMP($JOB,"RADIST",$SELECT(RALOCSRT=1:RABTY,1:U),$SELECT(RASRT="P":RANME,RASRT="S":"A"_RASSN,RASRT="T":"A"_($$HRCNT^BDGF2(RASSN))),RARPT)=$SELECT($DATA(RARTST2I):RARTST2I,1:RARDIFN)
KILL RARTST2I
+25 ; use IHS health record number terminal digit order
+26 QUIT
+27 ;
PRNT IF '$DATA(^RARPT(RAR,0))
QUIT
IF $PIECE(^(0),"^",5)'="V"
QUIT
IF $DATA(^RABTCH(74.3,RAB,"M"))
SET RARTMES=^("M")_$SELECT($DATA(RABEG):" (REPRINT)",1:"")
+1 SET RASTFL=""
SET RARPT=RAR
DO ^RARTR
IF $GET(RAY3)<0
QUIT
+2 SET %DT="TX"
SET X="NOW"
DO ^%DT
+3 IF $DATA(^RABTCH(74.4,RARDIFN,0))
IF ($PIECE(^RABTCH(74.4,RARDIFN,0),"^",4)="")
Begin DoDot:1
+4 NEW D,D0,DA,DI,DIC,DIE,DQ,DR,X
+5 SET DA=RARDIFN
SET DIE="^RABTCH(74.4,"
+6 SET DR="3////"_DUZ_";4////"_Y
DO ^DIE
+7 QUIT
End DoDot:1
+8 SET RARTCNT=RARTCNT+1
QUIT
+9 ;
START ;RANGE is only defined if prt'g via 'Individual Ward' or 'Single Clinic'
+1 ;options. The next ward or clinic to be printed is saved in piece
+2 ;1 and 2 of RANGE (RANGE=ward or clinic ien^ward or clinic name^6 or 8)
+3 USE IO
+4 IF $DATA(RANGE)
Begin DoDot:1
+5 SET TEXT=""
SET RANGE=$TRANSLATE(RANGE,"~","^")
+6 FOR
SET TEXT=$ORDER(^TMP($JOB,"WARD/CLIN",TEXT))
IF TEXT=""
QUIT
Begin DoDot:2
+7 SET TEXTD0=0
+8 FOR
SET TEXTD0=$ORDER(^TMP($JOB,"WARD/CLIN",TEXT,TEXTD0))
IF TEXTD0'>0
QUIT
Begin DoDot:3
+9 SET $PIECE(RANGE,U,1,2)=TEXTD0_U_TEXT
DO START0
+10 QUIT
End DoDot:3
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 IF '$TEST
Begin DoDot:1
+14 DO START0
+15 QUIT
End DoDot:1
+16 KILL %DT,D0,D1,DA,DIC,DIE,DIR,DIRUT,DIWF,DIWL,DIWR,DR,POP,RABT,RABTY,RACNI
+17 KILL RADATE,RAIMAG,RAPRT,RAPRTF,RAPRTOK,RAST,Z,RARTMES,RARPT,RARTCNT,RAB
+18 KILL RARDIFN,RADIV,RASRT,RABEG,RAEND,RAR,RASSN,RANME,RADFN,RADT,RADTI
+19 KILL RANGE,RARPT,RAS1,RAS2,RASTFL,RALOCSRT,RARTST1,RAY1,TEXT,TEXTD0
+20 KILL ^TMP($JOB,"RADIST"),^TMP($JOB,"WARD/CLIN")
+21 DO CLOSE^RAUTL
+22 QUIT
+23 ;
START0 ;
+1 KILL ^TMP($JOB,"RADIST")
IF '$DATA(^RABTCH(74.3,RAB,0))
QUIT
SET Y=$PIECE(^(0),"^",2)
SET RABT=$SELECT(Y="I":6,Y="O":8,1:0)
SET RAPRTF=1
DO BANNER
+2 IF '$DATA(RABEG)
FOR RARDIFN=0:0
SET RARDIFN=$ORDER(^RABTCH(74.4,"C",RAB,RARDIFN))
IF 'RARDIFN
QUIT
IF $DATA(^RABTCH(74.4,RARDIFN,0))
IF '$PIECE(^(0),"^",4)
SET Y=^(0)
DO SET
+3 IF $DATA(RABEG)
FOR RADT=(RABEG-.0001):0
SET RADT=$ORDER(^RABTCH(74.4,"AD",RADT))
IF 'RADT!(RADT>RAEND)
QUIT
FOR RARDIFN=0:0
SET RARDIFN=$ORDER(^RABTCH(74.4,"AD",RADT,RARDIFN))
IF 'RARDIFN
QUIT
IF $DATA(^RABTCH(74.4,RARDIFN,0))
IF $PIECE(^(0),"^",11)=RAB
SET Y=^(0)
DO SET
+4 IF '$DATA(^TMP($JOB,"RADIST"))
Begin DoDot:1
+5 IF $Y>(IOSL-4)
WRITE @IOF
+6 WRITE !!,$GET(RARTMES),!!,"No reports met the criteria selected."
+7 IF $DATA(RANGE)
WRITE !,$PIECE("^^^^^Ward^^Clinic",U,$PIECE(RANGE,U,3)),": ",$PIECE(RANGE,U,2)
+8 QUIT
End DoDot:1
GOTO Q
+9 SET RABTY=""
SET RARTCNT=0
FOR RAS1=0:0
SET RABTY=$ORDER(^TMP($JOB,"RADIST",RABTY))
IF RABTY=""
QUIT
DO NEWLOC
DO SRT
+10 WRITE @IOF,"Total Number of Reports printed: ",RARTCNT,!!
+11 ;S DA=+RAB,DR="[RA DISTRIBUTION LOG]",DIE="^RABTCH(74.3,",RARTMES="" S:$D(RANGE) RARTMES=$P(RANGE,"^",2)
+12 ;D ^DIE K DE,DQ
+13 ; Added in patch 9 to stop endless loops...
START1 LOCK +^RABATCH(74.3,+RAB)
+1 SET RARTMES=""
IF $DATA(RANGE)
SET RARTMES=$PIECE(RANGE,U,2)
+2 SET RAIENS="+1,"_(+RAB)_","
SET RAFDA(74.33,RAIENS,.01)="NOW"
+3 DO UPDATE^DIE("E","RAFDA","RAIEN","RAERR")
+4 IF '$GET(RAIEN(1))
LOCK -^RABTCH(74.3,+RAB)
KILL RAIENS,RAIEN,RAFDA
GOTO START1
+5 KILL RAFDA,RAIENS
SET RAIENS=RAIEN(1)_","_(+RAB)_","
KILL RAIEN
+6 SET RAFDA(74.33,RAIENS,2)=$SELECT($DATA(RABEG):"R",1:"P")
+7 SET RAFDA(74.33,RAIENS,3)=DUZ
+8 SET RAFDA(74.33,RAIENS,4)=$EXTRACT(RARTMES,1,20)
+9 SET RAFDA(74.33,RAIENS,5)=RARTCNT
+10 DO FILE^DIE(,"RAFDA","RAERR")
+11 LOCK -^RABTCH(74.3,+RAB)
+12 KILL RAFDA,RAIENS,RAERR
Q DO BANNER
+1 QUIT
+2 ;
BANNER IF $DATA(^RABTCH(74.3,RAB,"M"))
SET RARTMES=^("M")_$SELECT($DATA(RABEG):" (REPRINT)",1:"")
+1 QUIT
NEWLOC ; Print Location/Requesting Physician data
+1 IF RABTY="^"
QUIT
+2 WRITE @IOF,!!!!!?10
+3 WRITE $SELECT(RABTY'["^":"L O C A T I O N : ",1:"REQUESTING PHYSICIAN: ")
+4 WRITE $SELECT(RABTY["^":$PIECE(RABTY,"^",2),1:RABTY)
+5 QUIT
