Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RARTST

RARTST.m

Go to the documentation of this file.
  1. RARTST ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Reports Distribution ;2/10/98 11:02
  1. ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
  1. STUFF D INIT G Q:'Y
  1. 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
  1. K RAY3,RAB,RARDIFN,RACAT,RAFL Q
  1. ;
  1. INIT ; initialize variables
  1. S Y=RARPT D RASET^RAUTL2 Q:'Y
  1. S RAY3=Y D MAIL
  1. Q
  1. ;
  1. CHK S RAFL=0 D UPDLOC^RAUTL10
  1. I RACAT="A" S RAFL=1 G S
  1. I RACAT="I",$P(RAY3,"^",6) S RAFL=1 G S
  1. I RACAT="O",$P(RAY3,"^",8) S RAFL=1 G S
  1. I RACAT="N",$S($P(RAY3,"^",9):1,$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"R")):1,1:0) S RAFL=1 G S
  1. Q:'RAFL
  1. S K RADUP744 I $G(RAB) D DUPCHK I $D(RADUP744) K RADUP744 Q
  1. K X744 S I=+$P(^RABTCH(74.4,0),"^",3)
  1. 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
  1. S ^RABTCH(74.4,I,0)=RARPT_"^"_DT_"^^^^"_$P(RAY3,U,6)_"^^"_$P(RAY3,U,8)_"^^^"_RAB_"^"_$P(RAY3,"^",14)
  1. S ^RABTCH(74.4,"B",RARPT,I)="",^RABTCH(74.4,"C",RAB,I)=""
  1. 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)
  1. S RARDIFN=I Q
  1. ;
  1. DUPCHK ;Check if this report (RARPT) is already in this queue (RAB)
  1. 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
  1. K X744
  1. Q
  1. ;
  1. RESET ;; **** Radiology Report Distribution File Rebuild Routine ****
  1. 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
  1. S ZTSAVE("RADT")="",ZTRTN="START^RARTST",IOP="Q" W ! D ZIS^RAUTL K IOP G Q
  1. START U IO S X="NOW",%DT="TX" D ^%DT D D^RAUTL W !!,"Distribution files rebuilding process beginning at ",Y
  1. 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)
  1. I '$D(RA) W !,"All Distribution Queues have been inactivated. Aborting Distribution File",!,"rebuild." G Q
  1. S C1=0
  1. 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 "."
  1. W !!?3,"Total reports used to rebuild files: ",C1
  1. S X="NOW",%DT="TX" D ^%DT D D^RAUTL W !!,*7,"Distribution files rebuilding process completed at ",Y,"."
  1. 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
  1. K DUOUT,I,POP,RAMES,ZTDESC,ZTRTN,ZTSAVE
  1. Q
  1. ;
  1. LOOP F RAB=0:0 S RAB=$O(RA(RAB)) Q:'RAB S RACAT=RA(RAB) D CHK
  1. Q
  1. ;
  1. PURGE ;; **** Routine to Purge Reports Distribution File ****
  1. 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
  1. S ZTSAVE("RADT")="",ZTRTN="PURGE1^RARTST",ZTIO=""
  1. S ZTDESC="Distribution Queue Purge",ZTDTH=$H
  1. D ^%ZTLOAD
  1. W !?5,*7,"Request ",$S($G(ZTSK)'>0:"NOT ",1:""),"Queued.",!
  1. G EXIT
  1. PURGE1 D KILL^XM K MSGTXT
  1. I '$D(RADT) S X1=DT,X2=-7 D C^%DTC S RADT=X
  1. S Y=RADT D D^RAUTL
  1. S MSGTXT(1)="Purge distribution files of reports printed before "_Y_"."
  1. S MSGTXT(2)=""
  1. S X="NOW",%DT="TX" D ^%DT D D^RAUTL
  1. S MSGTXT(3)="Distribution files purge process begun at "_Y_"."
  1. 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
  1. F RAB=0:0 S RAB=$O(^RABTCH(74.3,RAB)) Q:'RAB D
  1. . S INACTDT=+$P($G(^RABTCH(74.3,RAB,"I")),"^")
  1. . 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
  1. . 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
  1. . Q
  1. S X="NOW",%DT="TX" D ^%DT,D^RAUTL
  1. S MSGTXT(4)="Distribution files purge process completed at "_Y_"."
  1. S XMTEXT="MSGTXT(",XMSUB="Distribution Queue Purge",XMY(DUZ)=""
  1. S XMDUZ="Radiology Package"
  1. D ^XMD,KILL^XM
  1. EXIT K %DT,%X,%Y,D,DA,DIC,DIK,INACTDT,MSGTXT,POP,RA744,RADTI,RADT,RARPT,RAB,RARDIFN,RADTE,X,Y,ZTSK
  1. K A1,DDH,I,POP
  1. S:$D(ZTQUEUED) ZTREQ="@"
  1. Q
  1. MAIL ; Mail to Req. Physician if applicable
  1. N RA1,RA2,RA3,RA74,RA74IEN,RADIVISN,RASTAT,RAY0,RAY2,RAY3,X,Y
  1. S RA1=RADFN,RA2=RADTI,RA3=RACNI
  1. S RAY0=$G(^DPT(RA1,0)) Q:RAY0']""
  1. S RAY2=$G(^RADPT(RA1,"DT",RA2,0)) Q:RAY2']""
  1. S RAY3=$G(^RADPT(RA1,"DT",RA2,"P",RA3,0)) Q:RAY3']""
  1. S RA74IEN=RARPT,RA74(0)=$G(^RARPT(RARPT,0)) Q:RA74(0)']""
  1. S RASTAT=$$UP^XLFSTR($P(RA74(0),"^",5))
  1. 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
  1. I RASTAT="V",($P($G(^RA(79,+$G(RADIVISN),.1)),"^",26)),($D(^XMB(3.7,+$P(RAY3,"^",14),0))#2),($$ENV^RAUTL4()) D
  1. . N RAACNT,RARPHYS,RAUTOE
  1. . S RAACNT=0,RARPHYS=+$P(RAY3,"^",14),RAUTOE=""
  1. . D PRT^RARTR,EMAIL^RAUTL4
  1. . Q
  1. S RADFN=RA1,RADTI=RA2,RACNI=RA3,RARPT=RA74IEN
  1. Q