source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTST2.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 5.8 KB
Line 
1RARTST2 ;HISC/CAH,FPT,GJC,DAD AISC/MJK,RMO-Reports Distribution ;3/19/97 13:45
2 ;;5.0;Radiology/Nuclear Medicine;**8,9**;Mar 16, 1998
3SRT 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
4 Q
5SET S RARPT=+Y K RABTY D RASET^RAUTL2 Q:'Y S RAY3=$G(^RABTCH(74.4,RARDIFN,0)) Q:RAY3']""
6 I $D(^RABTCH(74.3,"B","REQUESTING PHYSICIAN",RAB))#2 D G SET1
7 . ; Requesting Physician functionality
8 . S:+$P(RAY3,"^",12) RABTY=$P($G(^VA(200,+$P(RAY3,"^",12),0)),"^")
9 . S:'+$P(RAY3,"^",12) RABTY=$P($G(^VA(200,+$P(Y,"^",14),0)),"^")
10 . S:RABTY']"" RABTY="Unknown" S RABTY="^"_RABTY
11 . Q
12 I RABT=6!(RABT=8) D Q:'$D(RABTY)
13 . S Y=+$P(RAY3,"^",RABT) Q:'Y
14 . I RABT=6,$D(^DIC(42,Y,0)) S RABTY=$P(^(0),"^")
15 . I RABT=8,$D(^SC(Y,0)) S RABTY=$P(^(0),"^")
16 . Q
17 E D
18 . N RA6,RA8 S RABTY="Unknown"
19 . S RA6=+$P(RAY3,"^",6),RA8=+$P(RAY3,"^",8)
20 . I RA6,'RA8 S RABTY=$S($D(^DIC(42,RA6,0)):$P(^(0),"^"),1:RABTY)
21 . I 'RA6,RA8 S RABTY=$S($D(^SC(RA8,0)):$P(^(0),"^"),1:RABTY)
22 . S:RABTY']"" RABTY="Unknown"
23 . Q
24 ;
25SET1 ; Set the data global
26 N RAEXIT S RAEXIT=0
27 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
28 ;If RANGE is defined, user is prt'g from 'Individual Ward' or 'Single
29 ; Clinic' option, and rpt should be bypassed if ward or clinic on the
30 ; file 74.3 rpt record does not one of the selected requesting loc's
31 ;If RANGE is NOT defined, user is prt'g from 'Print by Routine Queue'
32 ; option and bypass logic depends on which queue they are printing
33 ; from: If Requesting Phys. Queue, use requesting location (i.e. ward
34 ; or clinic on file 74.3) to determine if its division matches the
35 ; division selected. If File Room, Medical Records, or Other than
36 ; Ward or Clinic queues are being printed, use exam division (i.e.
37 ; division on exam record) to determine if exam's division matches
38 ; the division selected.
39 I '$D(RANGE),$D(^RABTCH(74.3,"B","REQUESTING PHYSICIAN",RAB)) D Q:RAEXIT
40 . I $P(RAY3,"^",6) S:'$D(RAF408($$GET1^DIQ(42,$P(RAY3,"^",6),.015,"I"))) RAEXIT=1
41 . I $P(RAY3,"^",8) S:'$D(RAF408($$GET1^DIQ(44,$P(RAY3,"^",8),3.5,"I"))) RAEXIT=1
42 . Q
43 I '$D(RANGE),('$D(^RABTCH(74.3,"B","REQUESTING PHYSICIAN",RAB))) Q:'$D(RA4(+$P(RAY1,"^",3)))
44 Q:'$D(^DPT(RADFN,0)) S RANME=^(0),RASSN=$$SSN^RAUTL,RASSN=$S(RASSN:$TR(RASSN,"-"),1:"999999999"),RANME=$P(RANME,"^")
45 S RARTST2=1 D UPDLOC^RAUTL10 K RARTST2 Q:'$D(RAPRTOK)
46 ;RARTST2I will only be defined if UPDLOC has deleted the file 74.4
47 ;entry RARDIFN. RARTST2I will be the modified File Room entry
48 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
49 Q
50 ;
51PRNT Q:'$D(^RARPT(RAR,0)) Q:$P(^(0),"^",5)'="V" S:$D(^RABTCH(74.3,RAB,"M")) RARTMES=^("M")_$S($D(RABEG):" (REPRINT)",1:"")
52 S RASTFL="" S RARPT=RAR D ^RARTR Q:$G(RAY3)<0
53 S %DT="TX",X="NOW" D ^%DT
54 I $D(^RABTCH(74.4,RARDIFN,0)),($P(^RABTCH(74.4,RARDIFN,0),"^",4)="") D
55 . N D,D0,DA,DI,DIC,DIE,DQ,DR,X
56 . S DA=RARDIFN,DIE="^RABTCH(74.4,"
57 . S DR="3////"_DUZ_";4////"_Y D ^DIE
58 . Q
59 S RARTCNT=RARTCNT+1 Q
60 ;
61START ;RANGE is only defined if prt'g via 'Individual Ward' or 'Single Clinic'
62 ;options. The next ward or clinic to be printed is saved in piece
63 ;1 and 2 of RANGE (RANGE=ward or clinic ien^ward or clinic name^6 or 8)
64 U IO
65 I $D(RANGE) D
66 . S TEXT="",RANGE=$TR(RANGE,"~","^")
67 . F S TEXT=$O(^TMP($J,"WARD/CLIN",TEXT)) Q:TEXT="" D
68 .. S TEXTD0=0
69 .. F S TEXTD0=$O(^TMP($J,"WARD/CLIN",TEXT,TEXTD0)) Q:TEXTD0'>0 D
70 ... S $P(RANGE,U,1,2)=TEXTD0_U_TEXT D START0
71 ... Q
72 .. Q
73 . Q
74 E D
75 . D START0
76 . Q
77 K %DT,D0,D1,DA,DIC,DIE,DIR,DIRUT,DIWF,DIWL,DIWR,DR,POP,RABT,RABTY,RACNI
78 K RADATE,RAIMAG,RAPRT,RAPRTF,RAPRTOK,RAST,Z,RARTMES,RARPT,RARTCNT,RAB
79 K RARDIFN,RADIV,RASRT,RABEG,RAEND,RAR,RASSN,RANME,RADFN,RADT,RADTI
80 K RANGE,RARPT,RAS1,RAS2,RASTFL,RALOCSRT,RARTST1,RAY1,TEXT,TEXTD0
81 K ^TMP($J,"RADIST"),^TMP($J,"WARD/CLIN")
82 D CLOSE^RAUTL
83 Q
84 ;
85START0 ;
86 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
87 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
88 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
89 I '$D(^TMP($J,"RADIST")) D G Q
90 . W:$Y>(IOSL-4) @IOF
91 . W !!,$G(RARTMES),!!,"No reports met the criteria selected."
92 . I $D(RANGE) W !,$P("^^^^^Ward^^Clinic",U,$P(RANGE,U,3)),": ",$P(RANGE,U,2)
93 . Q
94 S RABTY="",RARTCNT=0 F RAS1=0:0 S RABTY=$O(^TMP($J,"RADIST",RABTY)) Q:RABTY="" D NEWLOC,SRT
95 W @IOF,"Total Number of Reports printed: ",RARTCNT,!!
96 ;S DA=+RAB,DR="[RA DISTRIBUTION LOG]",DIE="^RABTCH(74.3,",RARTMES="" S:$D(RANGE) RARTMES=$P(RANGE,"^",2)
97 ;D ^DIE K DE,DQ
98 ; Added in patch 9 to stop endless loops...
99START1 L +^RABATCH(74.3,+RAB)
100 S RARTMES="" S:$D(RANGE) RARTMES=$P(RANGE,U,2)
101 S RAIENS="+1,"_(+RAB)_",",RAFDA(74.33,RAIENS,.01)="NOW"
102 D UPDATE^DIE("E","RAFDA","RAIEN","RAERR")
103 I '$G(RAIEN(1)) L -^RABTCH(74.3,+RAB) K RAIENS,RAIEN,RAFDA G START1
104 K RAFDA,RAIENS S RAIENS=RAIEN(1)_","_(+RAB)_"," K RAIEN
105 S RAFDA(74.33,RAIENS,2)=$S($D(RABEG):"R",1:"P")
106 S RAFDA(74.33,RAIENS,3)=DUZ
107 S RAFDA(74.33,RAIENS,4)=$E(RARTMES,1,20)
108 S RAFDA(74.33,RAIENS,5)=RARTCNT
109 D FILE^DIE(,"RAFDA","RAERR")
110 L -^RABTCH(74.3,+RAB)
111 K RAFDA,RAIENS,RAERR
112Q D BANNER
113 Q
114 ;
115BANNER I $D(^RABTCH(74.3,RAB,"M")) S RARTMES=^("M")_$S($D(RABEG):" (REPRINT)",1:"")
116 Q
117NEWLOC ; Print Location/Requesting Physician data
118 I RABTY="^" Q
119 W @IOF,!!!!!?10
120 W $S(RABTY'["^":"L O C A T I O N : ",1:"REQUESTING PHYSICIAN: ")
121 W $S(RABTY["^":$P(RABTY,"^",2),1:RABTY)
122 Q
Note: See TracBrowser for help on using the repository browser.