- 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 Jan 18, 2025@03:40:32 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