RARTST ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Reports Distribution ;2/10/98 11:02
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
STUFF D INIT G Q:'Y
F RAB=0:0 S RAB=$O(^RABTCH(74.3,RAB)) Q:'RAB I $S('$D(^(RAB,"I")):1,'^("I"):1,DT'>^("I"):1,1:0) S RACAT=$P(^(0),"^",2) D CHK
K RAY3,RAB,RARDIFN,RACAT,RAFL Q
;
INIT ; initialize variables
S Y=RARPT D RASET^RAUTL2 Q:'Y
S RAY3=Y D MAIL
Q
;
CHK S RAFL=0 D UPDLOC^RAUTL10
I RACAT="A" S RAFL=1 G S
I RACAT="I",$P(RAY3,"^",6) S RAFL=1 G S
I RACAT="O",$P(RAY3,"^",8) S RAFL=1 G S
I RACAT="N",$S($P(RAY3,"^",9):1,$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"R")):1,1:0) S RAFL=1 G S
Q:'RAFL
S K RADUP744 I $G(RAB) D DUPCHK I $D(RADUP744) K RADUP744 Q
K X744 S I=+$P(^RABTCH(74.4,0),"^",3)
LOCK S I=I+1 L +^RABTCH(74.4,I):1 I '$T!$D(^RABTCH(74.4,I)) L -^RABTCH(74.4,I) G LOCK
S ^RABTCH(74.4,I,0)=RARPT_"^"_DT_"^^^^"_$P(RAY3,U,6)_"^^"_$P(RAY3,U,8)_"^^^"_RAB_"^"_$P(RAY3,"^",14)
S ^RABTCH(74.4,"B",RARPT,I)="",^RABTCH(74.4,"C",RAB,I)=""
S ^RABTCH(74.4,0)=$P(^RABTCH(74.4,0),"^",1,2)_"^"_I_"^"_($P(^(0),"^",4)+1),^DISV($S($D(DUZ)#2:DUZ,1:0),"^RABTCH(74.4,")=I L -^RABTCH(74.4,I)
S RARDIFN=I Q
;
DUPCHK ;Check if this report (RARPT) is already in this queue (RAB)
K RADUP744 S X744=0 F S X744=$O(^RABTCH(74.4,"B",RARPT,X744)) Q:'X744 I $P($G(^RABTCH(74.4,X744,0)),U,11)=RAB S RADUP744=1
K X744
Q
;
RESET ;; **** Radiology Report Distribution File Rebuild Routine ****
W !!,$P($T(RESET),";;",2),! S %DT="AEX",%DT("A")="Use only reports verified on or after: " D ^%DT K %DT G:Y<0 Q S RADT=Y
S ZTSAVE("RADT")="",ZTRTN="START^RARTST",IOP="Q" W ! D ZIS^RAUTL K IOP G Q
START U IO S X="NOW",%DT="TX" D ^%DT D D^RAUTL W !!,"Distribution files rebuilding process beginning at ",Y
S X=$P(^RABTCH(74.4,0),"^",1,2)_"^^0" K ^RABTCH(74.4),RA S ^RABTCH(74.4,0)=X F RAB=0:0 S RAB=$O(^RABTCH(74.3,RAB)) Q:'RAB S:$S('$D(^(RAB,"I")):1,'^("I"):1,DT'>^("I"):1,1:0) RA(RAB)=$P(^(0),"^",2)
I '$D(RA) W !,"All Distribution Queues have been inactivated. Aborting Distribution File",!,"rebuild." G Q
S C1=0
F RA1=0:0 S RA1=$O(^RARPT("AA",RA1)) Q:(9999999.9999-RA1)<RADT!(RA1'>0) F RARPT=0:0 S RARPT=$O(^RARPT("AA",RA1,RARPT)) Q:RARPT'>0 I $D(^RARPT(RARPT,0)),$P(^(0),"^",5)="V" D INIT I Y S C1=C1+1 D LOOP W "."
W !!?3,"Total reports used to rebuild files: ",C1
S X="NOW",%DT="TX" D ^%DT D D^RAUTL W !!,*7,"Distribution files rebuilding process completed at ",Y,"."
Q K %X,%XX,%Y,%YY,RAY3,RA,RA1,RACAT,RAB,RARDIFN,RADT,C0,C1,RARPT,RADFN,RADATE,RADTI,RADTE,RACN,RACNI,RAB,RAPOP,X,Y D CLOSE^RAUTL
K DUOUT,I,POP,RAMES,ZTDESC,ZTRTN,ZTSAVE
Q
;
LOOP F RAB=0:0 S RAB=$O(RA(RAB)) Q:'RAB S RACAT=RA(RAB) D CHK
Q
;
PURGE ;; **** Routine to Purge Reports Distribution File ****
W !!,$P($T(PURGE),";;",2),! S %DT="AEX",%DT("A")="Purge distribution files of reports printed before: " D ^%DT K %DT G:Y<0 EXIT S RADT=Y
S ZTSAVE("RADT")="",ZTRTN="PURGE1^RARTST",ZTIO=""
S ZTDESC="Distribution Queue Purge",ZTDTH=$H
D ^%ZTLOAD
W !?5,*7,"Request ",$S($G(ZTSK)'>0:"NOT ",1:""),"Queued.",!
G EXIT
PURGE1 D KILL^XM K MSGTXT
I '$D(RADT) S X1=DT,X2=-7 D C^%DTC S RADT=X
S Y=RADT D D^RAUTL
S MSGTXT(1)="Purge distribution files of reports printed before "_Y_"."
S MSGTXT(2)=""
S X="NOW",%DT="TX" D ^%DT D D^RAUTL
S MSGTXT(3)="Distribution files purge process begun at "_Y_"."
F RADTE=0:0 S RADTE=$O(^RABTCH(74.4,"AD",RADTE)) Q:'RADTE!(RADTE>RADT) F RARDIFN=0:0 S RARDIFN=$O(^RABTCH(74.4,"AD",RADTE,RARDIFN)) Q:'RARDIFN S DIK="^RABTCH(74.4,",DA=RARDIFN D ^DIK
F RAB=0:0 S RAB=$O(^RABTCH(74.3,RAB)) Q:'RAB D
. S INACTDT=+$P($G(^RABTCH(74.3,RAB,"I")),"^")
. I INACTDT,RADT>INACTDT S RA744=0 F S RA744=$O(^RABTCH(74.4,"C",RAB,RA744)) Q:RA744'>0 I $P($G(^RABTCH(74.4,RA744,0)),"^",4)'>0 S DIK="^RABTCH(74.4,",DA=RA744 D ^DIK
. F RADTI=(9999999.9999-RADT):0 S RADTI=$O(^RABTCH(74.3,RAB,"L",RADTI)) Q:'RADTI S DIK="^RABTCH(74.3,"_RAB_",""L"",",DA=RADTI,DA(1)=RAB D ^DIK
. Q
S X="NOW",%DT="TX" D ^%DT,D^RAUTL
S MSGTXT(4)="Distribution files purge process completed at "_Y_"."
S XMTEXT="MSGTXT(",XMSUB="Distribution Queue Purge",XMY(DUZ)=""
S XMDUZ="Radiology Package"
D ^XMD,KILL^XM
EXIT K %DT,%X,%Y,D,DA,DIC,DIK,INACTDT,MSGTXT,POP,RA744,RADTI,RADT,RARPT,RAB,RARDIFN,RADTE,X,Y,ZTSK
K A1,DDH,I,POP
S:$D(ZTQUEUED) ZTREQ="@"
Q
MAIL ; Mail to Req. Physician if applicable
N RA1,RA2,RA3,RA74,RA74IEN,RADIVISN,RASTAT,RAY0,RAY2,RAY3,X,Y
S RA1=RADFN,RA2=RADTI,RA3=RACNI
S RAY0=$G(^DPT(RA1,0)) Q:RAY0']""
S RAY2=$G(^RADPT(RA1,"DT",RA2,0)) Q:RAY2']""
S RAY3=$G(^RADPT(RA1,"DT",RA2,"P",RA3,0)) Q:RAY3']""
S RA74IEN=RARPT,RA74(0)=$G(^RARPT(RARPT,0)) Q:RA74(0)']""
S RASTAT=$$UP^XLFSTR($P(RA74(0),"^",5))
S RADIVISN=+$$DIVSION^RAUTL6(DT,+$P($G(^RAO(75.1,+$P(RAY3,"^",11),0)),"^",22)) ; this will return a valid Institution file ptr value or -1 if in error
I RASTAT="V",($P($G(^RA(79,+$G(RADIVISN),.1)),"^",26)),($D(^XMB(3.7,+$P(RAY3,"^",14),0))#2),($$ENV^RAUTL4()) D
. N RAACNT,RARPHYS,RAUTOE
. S RAACNT=0,RARPHYS=+$P(RAY3,"^",14),RAUTOE=""
. D PRT^RARTR,EMAIL^RAUTL4
. Q
S RADFN=RA1,RADTI=RA2,RACNI=RA3,RARPT=RA74IEN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRARTST 5154 printed Sep 23, 2025@20:15:38 Page 2
RARTST ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Reports Distribution ;2/10/98 11:02
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
STUFF DO INIT
if 'Y
GOTO Q
+1 FOR RAB=0:0
SET RAB=$ORDER(^RABTCH(74.3,RAB))
if 'RAB
QUIT
IF $SELECT('$DATA(^(RAB,"I")):1,'^("I"):1,DT'>^("I"):1,1:0)
SET RACAT=$PIECE(^(0),"^",2)
DO CHK
+2 KILL RAY3,RAB,RARDIFN,RACAT,RAFL
QUIT
+3 ;
INIT ; initialize variables
+1 SET Y=RARPT
DO RASET^RAUTL2
if 'Y
QUIT
+2 SET RAY3=Y
DO MAIL
+3 QUIT
+4 ;
CHK SET RAFL=0
DO UPDLOC^RAUTL10
+1 IF RACAT="A"
SET RAFL=1
GOTO S
+2 IF RACAT="I"
IF $PIECE(RAY3,"^",6)
SET RAFL=1
GOTO S
+3 IF RACAT="O"
IF $PIECE(RAY3,"^",8)
SET RAFL=1
GOTO S
+4 IF RACAT="N"
IF $SELECT($PIECE(RAY3,"^",9):1,$DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"R")):1,1:0)
SET RAFL=1
GOTO S
+5 if 'RAFL
QUIT
S KILL RADUP744
IF $GET(RAB)
DO DUPCHK
IF $DATA(RADUP744)
KILL RADUP744
QUIT
+1 KILL X744
SET I=+$PIECE(^RABTCH(74.4,0),"^",3)
LOCK SET I=I+1
LOCK +^RABTCH(74.4,I):1
IF '$TEST!$DATA(^RABTCH(74.4,I))
LOCK -^RABTCH(74.4,I)
GOTO LOCK
+1 SET ^RABTCH(74.4,I,0)=RARPT_"^"_DT_"^^^^"_$PIECE(RAY3,U,6)_"^^"_$PIECE(RAY3,U,8)_"^^^"_RAB_"^"_$PIECE(RAY3,"^",14)
+2 SET ^RABTCH(74.4,"B",RARPT,I)=""
SET ^RABTCH(74.4,"C",RAB,I)=""
+3 SET ^RABTCH(74.4,0)=$PIECE(^RABTCH(74.4,0),"^",1,2)_"^"_I_"^"_($PIECE(^(0),"^",4)+1)
SET ^DISV($SELECT($DATA(DUZ)#2:DUZ,1:0),"^RABTCH(74.4,")=I
LOCK -^RABTCH(74.4,I)
+4 SET RARDIFN=I
QUIT
+5 ;
DUPCHK ;Check if this report (RARPT) is already in this queue (RAB)
+1 KILL RADUP744
SET X744=0
FOR
SET X744=$ORDER(^RABTCH(74.4,"B",RARPT,X744))
if 'X744
QUIT
IF $PIECE($GET(^RABTCH(74.4,X744,0)),U,11)=RAB
SET RADUP744=1
+2 KILL X744
+3 QUIT
+4 ;
RESET ;; **** Radiology Report Distribution File Rebuild Routine ****
+1 WRITE !!,$PIECE($TEXT(RESET),";;",2),!
SET %DT="AEX"
SET %DT("A")="Use only reports verified on or after: "
DO ^%DT
KILL %DT
if Y<0
GOTO Q
SET RADT=Y
+2 SET ZTSAVE("RADT")=""
SET ZTRTN="START^RARTST"
SET IOP="Q"
WRITE !
DO ZIS^RAUTL
KILL IOP
GOTO Q
START USE IO
SET X="NOW"
SET %DT="TX"
DO ^%DT
DO D^RAUTL
WRITE !!,"Distribution files rebuilding process beginning at ",Y
+1 SET X=$PIECE(^RABTCH(74.4,0),"^",1,2)_"^^0"
KILL ^RABTCH(74.4),RA
SET ^RABTCH(74.4,0)=X
FOR RAB=0:0
SET RAB=$ORDER(^RABTCH(74.3,RAB))
if 'RAB
QUIT
if $SELECT('$DATA(^(RAB,"I"))
SET RA(RAB)=$PIECE(^(0),"^",2)
+2 IF '$DATA(RA)
WRITE !,"All Distribution Queues have been inactivated. Aborting Distribution File",!,"rebuild."
GOTO Q
+3 SET C1=0
+4 FOR RA1=0:0
SET RA1=$ORDER(^RARPT("AA",RA1))
if (9999999.9999-RA1)<RADT!(RA1'>0)
QUIT
FOR RARPT=0:0
SET RARPT=$ORDER(^RARPT("AA",RA1,RARPT))
if RARPT'>0
QUIT
IF $DATA(^RARPT(RARPT,0))
IF $PIECE(^(0),"^",5)="V"
DO INIT
IF Y
SET C1=C1+1
DO LOOP
WRITE "."
+5 WRITE !!?3,"Total reports used to rebuild files: ",C1
+6 SET X="NOW"
SET %DT="TX"
DO ^%DT
DO D^RAUTL
WRITE !!,*7,"Distribution files rebuilding process completed at ",Y,"."
Q KILL %X,%XX,%Y,%YY,RAY3,RA,RA1,RACAT,RAB,RARDIFN,RADT,C0,C1,RARPT,RADFN,RADATE,RADTI,RADTE,RACN,RACNI,RAB,RAPOP,X,Y
DO CLOSE^RAUTL
+1 KILL DUOUT,I,POP,RAMES,ZTDESC,ZTRTN,ZTSAVE
+2 QUIT
+3 ;
LOOP FOR RAB=0:0
SET RAB=$ORDER(RA(RAB))
if 'RAB
QUIT
SET RACAT=RA(RAB)
DO CHK
+1 QUIT
+2 ;
PURGE ;; **** Routine to Purge Reports Distribution File ****
+1 WRITE !!,$PIECE($TEXT(PURGE),";;",2),!
SET %DT="AEX"
SET %DT("A")="Purge distribution files of reports printed before: "
DO ^%DT
KILL %DT
if Y<0
GOTO EXIT
SET RADT=Y
+2 SET ZTSAVE("RADT")=""
SET ZTRTN="PURGE1^RARTST"
SET ZTIO=""
+3 SET ZTDESC="Distribution Queue Purge"
SET ZTDTH=$HOROLOG
+4 DO ^%ZTLOAD
+5 WRITE !?5,*7,"Request ",$SELECT($GET(ZTSK)'>0:"NOT ",1:""),"Queued.",!
+6 GOTO EXIT
PURGE1 DO KILL^XM
KILL MSGTXT
+1 IF '$DATA(RADT)
SET X1=DT
SET X2=-7
DO C^%DTC
SET RADT=X
+2 SET Y=RADT
DO D^RAUTL
+3 SET MSGTXT(1)="Purge distribution files of reports printed before "_Y_"."
+4 SET MSGTXT(2)=""
+5 SET X="NOW"
SET %DT="TX"
DO ^%DT
DO D^RAUTL
+6 SET MSGTXT(3)="Distribution files purge process begun at "_Y_"."
+7 FOR RADTE=0:0
SET RADTE=$ORDER(^RABTCH(74.4,"AD",RADTE))
if 'RADTE!(RADTE>RADT)
QUIT
FOR RARDIFN=0:0
SET RARDIFN=$ORDER(^RABTCH(74.4,"AD",RADTE,RARDIFN))
if 'RARDIFN
QUIT
SET DIK="^RABTCH(74.4,"
SET DA=RARDIFN
DO ^DIK
+8 FOR RAB=0:0
SET RAB=$ORDER(^RABTCH(74.3,RAB))
if 'RAB
QUIT
Begin DoDot:1
+9 SET INACTDT=+$PIECE($GET(^RABTCH(74.3,RAB,"I")),"^")
+10 IF INACTDT
IF RADT>INACTDT
SET RA744=0
FOR
SET RA744=$ORDER(^RABTCH(74.4,"C",RAB,RA744))
if RA744'>0
QUIT
IF $PIECE($GET(^RABTCH(74.4,RA744,0)),"^",4)'>0
SET DIK="^RABTCH(74.4,"
SET DA=RA744
DO ^DIK
+11 FOR RADTI=(9999999.9999-RADT):0
SET RADTI=$ORDER(^RABTCH(74.3,RAB,"L",RADTI))
if 'RADTI
QUIT
SET DIK="^RABTCH(74.3,"_RAB_",""L"","
SET DA=RADTI
SET DA(1)=RAB
DO ^DIK
+12 QUIT
End DoDot:1
+13 SET X="NOW"
SET %DT="TX"
DO ^%DT
DO D^RAUTL
+14 SET MSGTXT(4)="Distribution files purge process completed at "_Y_"."
+15 SET XMTEXT="MSGTXT("
SET XMSUB="Distribution Queue Purge"
SET XMY(DUZ)=""
+16 SET XMDUZ="Radiology Package"
+17 DO ^XMD
DO KILL^XM
EXIT KILL %DT,%X,%Y,D,DA,DIC,DIK,INACTDT,MSGTXT,POP,RA744,RADTI,RADT,RARPT,RAB,RARDIFN,RADTE,X,Y,ZTSK
+1 KILL A1,DDH,I,POP
+2 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 QUIT
MAIL ; Mail to Req. Physician if applicable
+1 NEW RA1,RA2,RA3,RA74,RA74IEN,RADIVISN,RASTAT,RAY0,RAY2,RAY3,X,Y
+2 SET RA1=RADFN
SET RA2=RADTI
SET RA3=RACNI
+3 SET RAY0=$GET(^DPT(RA1,0))
if RAY0']""
QUIT
+4 SET RAY2=$GET(^RADPT(RA1,"DT",RA2,0))
if RAY2']""
QUIT
+5 SET RAY3=$GET(^RADPT(RA1,"DT",RA2,"P",RA3,0))
if RAY3']""
QUIT
+6 SET RA74IEN=RARPT
SET RA74(0)=$GET(^RARPT(RARPT,0))
if RA74(0)']""
QUIT
+7 SET RASTAT=$$UP^XLFSTR($PIECE(RA74(0),"^",5))
+8 ; this will return a valid Institution file ptr value or -1 if in error
SET RADIVISN=+$$DIVSION^RAUTL6(DT,+$PIECE($GET(^RAO(75.1,+$PIECE(RAY3,"^",11),0)),"^",22))
+9 IF RASTAT="V"
IF ($PIECE($GET(^RA(79,+$GET(RADIVISN),.1)),"^",26))
IF ($DATA(^XMB(3.7,+$PIECE(RAY3,"^",14),0))#2)
IF ($$ENV^RAUTL4())
Begin DoDot:1
+10 NEW RAACNT,RARPHYS,RAUTOE
+11 SET RAACNT=0
SET RARPHYS=+$PIECE(RAY3,"^",14)
SET RAUTOE=""
+12 DO PRT^RARTR
DO EMAIL^RAUTL4
+13 QUIT
End DoDot:1
+14 SET RADFN=RA1
SET RADTI=RA2
SET RACNI=RA3
SET RARPT=RA74IEN
+15 QUIT
