source: WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPURGE1.m@ 1154

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

initial load of WorldVistAEHR
File size: 6.4 KB
Line 
1RAPURGE1 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Purge Rad/NM Data ;9/3/97 12:22
2 ;;5.0;Radiology/Nuclear Medicine;**34**;Mar 16, 1998
3START I $G(RAPURTYP)="" U IO W !,"RAPURTYP undefined or null, Purge Not Done." G EXIT
4 U IO D NOW^%DTC S Y=%,RACRT=$E(IOST,1,2)="C-" K %,%H,%I W !!,"Purge data routine started at " D D^RAUTL W Y,"."
5 ;Set up variables needed for purge of selected imaging types
6 G EXIT:'$O(RAPUR(0))
7 S (RADT,RAODT,RAIEN)=0 F S RAIEN=$O(RAPUR(RAIEN)) Q:'RAIEN S RAX=$G(^RA(79.2,RAIEN,.1)) D
8 .F RAI=1:1:4 S X2=-$S($P(RAX,U,RAI)>89:$P(RAX,U,RAI),1:27393),X1=DT D C^%DTC S $P(RAPUR(RAIEN),"^",RAI)=X S:X>RADT RADT=X
9 .S X2=-$S($P(RAX,U,6)>29:$P(RAX,U,6),1:27393),X1=DT D C^%DTC S $P(RAPUR(RAIEN),"^",5)=X S:X>RAODT RAODT=X
10 .F RAI=6:1:8 S $P(RAPUR(RAIEN),"^",RAI)=0
11 ;
12EXAM ;Purge exam/report data
13 I RAPURTYP="O" G ORDER
14 W !!,"Purging exams/reports.",!
15 F RADTE=0:0 S RADTE=$O(^RADPT("AR",RADTE)) Q:RADTE'>0!(RADTE>RADT) S RADTI=9999999.9999-RADTE F RADFN=0:0 S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:RADFN'>0 D
16 .F RACN=0:0 S RACN=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN)) Q:RACN'>0 S RACNI=+$O(^(RACN,0)),RA0=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),RARPT=+$P(RA0,"^",17) D:$S('$D(^("NOPURGE")):1,^("NOPURGE")'="n":1,1:0)
17 ..S RAIMAG=+$P($G(^RAMIS(71,+$P(RA0,"^",2),0)),"^",12) Q:'$D(RAPUR(RAIMAG)) W:RACRT "."
18 ..K RARP S RARPTNP=$G(^RARPT(RARPT,"NOPURGE")) I $S('$D(^RARPT(RARPT,0)):0,RAREPURG:1,'$D(^("PURGE")):1,1:0),RARPTNP'="n","RBA"[RAPURTYP D
19 ... Q:+$O(^RARPT(RARPT,"ERR",0)) ; quit if report amended
20 ...I $P(RAPUR(RAIMAG),"^",2)>RADTE,$D(^RARPT(RARPT,"R")) K ^("R") S RARP=""
21 ...I $P(RAPUR(RAIMAG),"^")>RADTE,$D(^RARPT(RARPT,"L")) K ^("L") S RARP=""
22 ...I $P(RAPUR(RAIMAG),"^",3)>RADTE,$D(^RARPT(RARPT,"H")) K ^("H") S RARP=""
23 ..S:$D(RARP) ^RARPT(RARPT,"PURGE")=DT,$P(RAPUR(RAIMAG),"^",7)=$P(RAPUR(RAIMAG),"^",7)+1
24 ..K RAEX I $S(RAREPURG:1,'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PURGE")):1,1:0),"EBA"[RAPURTYP D
25 ...I $P(RAPUR(RAIMAG),"^")>RADTE,$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L")) K ^("L") S RAEX=""
26 ...I $P(RAPUR(RAIMAG),"^",3)>RADTE,$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H")) K ^("H") S RAEX=""
27 ...I $P(RAPUR(RAIMAG),"^",4)>RADTE,$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"T")) K ^("T") S RAEX=""
28 ..S:$D(RAEX) ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PURGE")=DT,$P(RAPUR(RAIMAG),"^",6)=$P(RAPUR(RAIMAG),"^",6)+1
29 ;
30ORDER ;Purge order/request data
31 I "OA"'[RAPURTYP G STAT
32 W !,"Purging orders/requests.",!
33 S RAPKG="" F RAODTE=0:0 S RAODTE=$O(^RAO(75.1,"AO",RAODTE)) Q:'RAODTE!(RAODTE>RAODT) F RAOIFN=0:0 S RAOIFN=$O(^RAO(75.1,"AO",RAODTE,RAOIFN)) Q:'RAOIFN S RAORD0=$G(^RAO(75.1,RAOIFN,0)),RAIMAG=+$P(RAORD0,"^",3) D
34 .I $D(RAPUR(RAIMAG)),$P(RAORD0,"^",5)<6 S RAPUROK=$$PUROK(RAORD0,DT) D:RAPUROK ENPUR
35 ;
36 ;Update statistics in Imaging Type file (#79.2)
37STAT D NOW^%DTC S Y=% K %,%H,%I W !,"Data purge completed at " D D^RAUTL W Y,".",!!,"The following purge statistics were compiled:"
38 K RAX S RAX="" F S RAX=$O(RAPUR(RAX)) Q:'RAX S DA=RAX,DIE="^RA(79.2,",DR="100///""NOW""",DR(2,79.23)="2///P;3////"_DUZ_";4///"_$P(RAPUR(RAX),U,6)_";5///"_$P(RAPUR(RAX),"^",7)_";6///"_$P(RAPUR(RAX),"^",8) D ^DIE D
39 .W !!,"Imaging Type: ",$P($G(^RA(79.2,RAX,0)),"^"),!
40 .W !?5,"No. of exam records processed : ",$P(RAPUR(RAX),"^",6)
41 .W !?5,"No. of reports processed : ",$P(RAPUR(RAX),"^",7)
42 .W !?5,"No. of requests processed : ",$P(RAPUR(RAX),"^",8)
43EXIT K %DT,%T,D,D0,D1,DA,DDER,DE,DI,DIC,DIE,DQ,DR,DLAYGO,POP,RA0,RACN,RACNI
44 K RACRT,RADFN,RADT,RADTE,RADTI,RAEX,RAI,RAIEN,RAIMAG,RAODT,RAODTE
45 K RAOIFN,RAORD0,RAPKG,RAPOP,RAPUR,RAREPURG,RARP,RARPT,RARPTNP,RAX,X
46 K RAGO,RAPURTYP
47 K X1,X2,Y K:$G(RAORD)'="Z@" RAPUROK ; don't kill if entering through
48 ; the front door & version of CPRS >2.5 RAPUROK checked in RAO7RO
49 D CLOSE^RAUTL
50 Q
51 ;
52ENPUR ;OE/RR Entry Point for the PURGE ACTION Option
53 I '$D(RAPKG),($$ORVR^RAORDU()=2.5) Q:'$D(ORPK)!('$D(ORSTS)) S OREND=$S(ORSTS<6:0,1:1) Q:OREND!(ORPK'>0) S RAOIFN=+ORPK
54 ;
55 ; The 'DELORD' subroutine deletes the Imaging Order data
56 ; (field 11) in the 70.03 sub-file. This code handles deletions
57 ; for parent procedures as well as orphan procedures (non-parent).
58 ;
59 D DELORD(RAOIFN,+$G(RAORD0)) ; +$G(RAORD0) is the patient dfn
60 I $D(RAPKG) D ; track the # of requests processed
61 . W:RACRT "." S $P(RAPUR(RAIMAG),"^",8)=$P(RAPUR(RAIMAG),"^",8)+1
62 . Q
63 I $$ORVR^RAORDU()=2.5 D
64 . I $D(RAPKG) S ORIFN=+$P(RAORD0,"^",7),ORSTS="K" D:ORIFN ST^ORX K ORIFN,ORSTS
65 . I '$D(RAPKG) S ORSTS="K" D:ORIFN ST^ORX K ORIFN,ORSTS
66 . Q
67 K %,DA,DIC,DIK
68 D:$$ORVR^RAORDU()'<3&($G(RAORD)'="Z@") EN1^RAO7PURG(RAOIFN)
69 ; do EN1^RAO7PURG only if we are going through the 'backdoor' for
70 ; versions of CPRS 3.0 or greater.
71 S DA=RAOIFN,DIK="^RAO(75.1," D ^DIK ; delete the order record
72 K %,DA,DIC,DIK
73 Q
74DELORD(RAOIFN,RADFN) ; Delete all of the imaging order pointers that refer
75 ; to a specific order.
76 ; input: raoifn-ien of our order in file 75.1
77 ; radfn-ien of the patient associated with the order
78 N RACNI,RADTI,X,Y S RADTI=0
79 F S RADTI=$O(^RADPT("AO",RAOIFN,RADFN,RADTI)) Q:RADTI'>0 D
80 . S RACNI=0
81 . F S RACNI=$O(^RADPT("AO",RAOIFN,RADFN,RADTI,RACNI)) Q:RACNI'>0 D
82 .. K %,D,D0,DA,DIC,DIE,DQ,DR
83 .. S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DR="11///@"
84 .. S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
85 .. D ^DIE K %,D,D0,DA,DIC,DIE,DQ,DR
86 .. Q
87 . Q
88 Q
89PUROK(RAORD0,RATDAY) ; Determine if an order meets the criteria
90 ; to be purged from the Rad/Nuc Med Orders file.
91 ; Input: RAORD0-0 node of the order record from file 75.1
92 ; : RATDAY-the current date w/o time
93 ; Output: 1 if the order meets the purge criteria, else 0
94 N RAOSTAT S RAOSTAT=$P(RAORD0,"^",5)
95 ;
96 ; PENDING & ('Date Desired' -or- 'Sheduled Date' >= today), don't purge
97 Q:RAOSTAT=5&(($P(RAORD0,"^",21)\1)'<RATDAY) 0 ; Date Desired
98 Q:RAOSTAT=5&(($P(RAORD0,"^",23)\1)'<RATDAY) 0 ; Sch'ld date
99 ; HOLD & ('Date Desired' -or- 'Sheduled Date' >= today), don't purge
100 Q:RAOSTAT=3&(($P(RAORD0,"^",21)\1)'<RATDAY) 0 ; Date Desired
101 Q:RAOSTAT=3&(($P(RAORD0,"^",23)\1)'<RATDAY) 0 ; Sch'ld date
102 ;
103 ; PENDING & 'Request Entered Date/Time' < than 1 year ago, don't purge
104 I RAOSTAT=5,($P(RAORD0,"^",16)) Q:$P(RAORD0,"^",16)'<($$FMADD^XLFDT(RATDAY,-365)) 0
105 ; HOLD & 'Request Entered Date/Time' < than 1 year ago, don't purge
106 I RAOSTAT=3,($P(RAORD0,"^",16)) Q:$P(RAORD0,"^",16)'<($$FMADD^XLFDT(RATDAY,-365)) 0
107 ; Orders that are in a status of: DISCONTINUED or COMPLETE are purged
108 ; when they have no activity after the cut-off date for their img type
109 Q 1
Note: See TracBrowser for help on using the repository browser.