source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTST.m@ 1611

Last change on this file since 1611 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.9 KB
Line 
1RARTST ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Reports Distribution ;2/10/98 11:02
2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
3STUFF D INIT G Q:'Y
4 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
5 K RAY3,RAB,RARDIFN,RACAT,RAFL Q
6 ;
7INIT ; initialize variables
8 S Y=RARPT D RASET^RAUTL2 Q:'Y
9 S RAY3=Y D MAIL
10 Q
11 ;
12CHK S RAFL=0 D UPDLOC^RAUTL10
13 I RACAT="A" S RAFL=1 G S
14 I RACAT="I",$P(RAY3,"^",6) S RAFL=1 G S
15 I RACAT="O",$P(RAY3,"^",8) S RAFL=1 G S
16 I RACAT="N",$S($P(RAY3,"^",9):1,$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"R")):1,1:0) S RAFL=1 G S
17 Q:'RAFL
18S K RADUP744 I $G(RAB) D DUPCHK I $D(RADUP744) K RADUP744 Q
19 K X744 S I=+$P(^RABTCH(74.4,0),"^",3)
20LOCK S I=I+1 L +^RABTCH(74.4,I):1 I '$T!$D(^RABTCH(74.4,I)) L -^RABTCH(74.4,I) G LOCK
21 S ^RABTCH(74.4,I,0)=RARPT_"^"_DT_"^^^^"_$P(RAY3,U,6)_"^^"_$P(RAY3,U,8)_"^^^"_RAB_"^"_$P(RAY3,"^",14)
22 S ^RABTCH(74.4,"B",RARPT,I)="",^RABTCH(74.4,"C",RAB,I)=""
23 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)
24 S RARDIFN=I Q
25 ;
26DUPCHK ;Check if this report (RARPT) is already in this queue (RAB)
27 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
28 K X744
29 Q
30 ;
31RESET ;; **** Radiology Report Distribution File Rebuild Routine ****
32 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
33 S ZTSAVE("RADT")="",ZTRTN="START^RARTST",IOP="Q" W ! D ZIS^RAUTL K IOP G Q
34START U IO S X="NOW",%DT="TX" D ^%DT D D^RAUTL W !!,"Distribution files rebuilding process beginning at ",Y
35 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)
36 I '$D(RA) W !,"All Distribution Queues have been inactivated. Aborting Distribution File",!,"rebuild." G Q
37 S C1=0
38 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 "."
39 W !!?3,"Total reports used to rebuild files: ",C1
40 S X="NOW",%DT="TX" D ^%DT D D^RAUTL W !!,*7,"Distribution files rebuilding process completed at ",Y,"."
41Q 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
42 K DUOUT,I,POP,RAMES,ZTDESC,ZTRTN,ZTSAVE
43 Q
44 ;
45LOOP F RAB=0:0 S RAB=$O(RA(RAB)) Q:'RAB S RACAT=RA(RAB) D CHK
46 Q
47 ;
48PURGE ;; **** Routine to Purge Reports Distribution File ****
49 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
50 S ZTSAVE("RADT")="",ZTRTN="PURGE1^RARTST",ZTIO=""
51 S ZTDESC="Distribution Queue Purge",ZTDTH=$H
52 D ^%ZTLOAD
53 W !?5,*7,"Request ",$S($G(ZTSK)'>0:"NOT ",1:""),"Queued.",!
54 G EXIT
55PURGE1 D KILL^XM K MSGTXT
56 I '$D(RADT) S X1=DT,X2=-7 D C^%DTC S RADT=X
57 S Y=RADT D D^RAUTL
58 S MSGTXT(1)="Purge distribution files of reports printed before "_Y_"."
59 S MSGTXT(2)=""
60 S X="NOW",%DT="TX" D ^%DT D D^RAUTL
61 S MSGTXT(3)="Distribution files purge process begun at "_Y_"."
62 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
63 F RAB=0:0 S RAB=$O(^RABTCH(74.3,RAB)) Q:'RAB D
64 . S INACTDT=+$P($G(^RABTCH(74.3,RAB,"I")),"^")
65 . 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
66 . 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
67 . Q
68 S X="NOW",%DT="TX" D ^%DT,D^RAUTL
69 S MSGTXT(4)="Distribution files purge process completed at "_Y_"."
70 S XMTEXT="MSGTXT(",XMSUB="Distribution Queue Purge",XMY(DUZ)=""
71 S XMDUZ="Radiology Package"
72 D ^XMD,KILL^XM
73EXIT K %DT,%X,%Y,D,DA,DIC,DIK,INACTDT,MSGTXT,POP,RA744,RADTI,RADT,RARPT,RAB,RARDIFN,RADTE,X,Y,ZTSK
74 K A1,DDH,I,POP
75 S:$D(ZTQUEUED) ZTREQ="@"
76 Q
77MAIL ; Mail to Req. Physician if applicable
78 N RA1,RA2,RA3,RA74,RA74IEN,RADIVISN,RASTAT,RAY0,RAY2,RAY3,X,Y
79 S RA1=RADFN,RA2=RADTI,RA3=RACNI
80 S RAY0=$G(^DPT(RA1,0)) Q:RAY0']""
81 S RAY2=$G(^RADPT(RA1,"DT",RA2,0)) Q:RAY2']""
82 S RAY3=$G(^RADPT(RA1,"DT",RA2,"P",RA3,0)) Q:RAY3']""
83 S RA74IEN=RARPT,RA74(0)=$G(^RARPT(RARPT,0)) Q:RA74(0)']""
84 S RASTAT=$$UP^XLFSTR($P(RA74(0),"^",5))
85 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
86 I RASTAT="V",($P($G(^RA(79,+$G(RADIVISN),.1)),"^",26)),($D(^XMB(3.7,+$P(RAY3,"^",14),0))#2),($$ENV^RAUTL4()) D
87 . N RAACNT,RARPHYS,RAUTOE
88 . S RAACNT=0,RARPHYS=+$P(RAY3,"^",14),RAUTOE=""
89 . D PRT^RARTR,EMAIL^RAUTL4
90 . Q
91 S RADFN=RA1,RADTI=RA2,RACNI=RA3,RARPT=RA74IEN
92 Q
Note: See TracBrowser for help on using the repository browser.