source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTAPSL.m@ 1766

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

initial load of WorldVistAEHR

File size: 4.8 KB
Line 
1DGPTAPSL ;MTC/ALB - PTF Archive and Purge Selection Routines; 9/11/92
2 ;;5.3;Registration;**31**;Aug 13, 1993
3 ;
4SEL() ;-- the routine will get the date range for the a/p process
5 N SDATE,EDATE,Y
6 S (SDATE,EDATE)=""
7 ;-- get oldest record on file
8 S Y=$O(^DGPT("AF",0)) D DD^%DT W !,"The oldest PTF record on file is from ",Y,"."
9 S DIR(0)="D^:"_$$MAXDT(),DIR("A")="Please enter the date to begin search"
10 D ^DIR
11 G:$D(DIRUT) SELQ S SDATE=Y
12 S DIR(0)="D^"_Y_":"_$$MAXDT(),DIR("A")="Please enter the date to end search"
13 D ^DIR
14 G:$D(DIRUT) SELQ S EDATE=Y
15SELQ Q SDATE_"^"_EDATE
16 ;
17MAXDT() ;-- This function will return the lastest date allowable for
18 ;purge. The date is based on the current FY - X; where X is
19 ;number of years determined by VACO.
20 ; OUTPUT - date in FM format
21 N DATE,YEARS
22 S YEARS=3,DATE=""
23 D NOW^%DTC
24 ;-- get current FY
25 I %I(1)>9,%I(1)<13 S DATE=%I(3)+1
26 I %I(1)>0,%I(1)<10 S DATE=%I(3)
27 ;-- adjust max date by YEARS
28 S DATE=(DATE-YEARS)_"0930"
29 K %I,X
30 Q DATE
31 ;
32SRCH(GLB,DRANGE) ;-- search PTF file by adm date
33 ; INPUT: GLB - Global to load entries ex. "^TMP("MATT",$J,"
34 ; DRANGE - start date ^ end date in FM format
35 ;
36 ; OUTPUT: Total # of entires loaded into GLB
37 N SDATE,EDATE,PDATE,NREC,PTF
38 S NREC=0,SDATE=$P(DRANGE,U),EDATE=$P(DRANGE,U,2)
39 S PDATE=SDATE-.0000001 F S PDATE=$O(^DGPT("AF",PDATE)) Q:'PDATE!(PDATE>EDATE) S PTF=0 F S PTF=$O(^DGPT("AF",PDATE,PTF)) Q:'PTF I $$SHUDADD(PTF,DRANGE) S @(GLB_PTF_")")="",NREC=NREC+1
40 Q NREC
41 ;
42SHUDADD(PTF,DRANGE) ;-- routine to determin if the PTF records should be added to purge
43 ; INPUT : PTF - record to check
44 ; DRANGE - start and end date of search
45 ; OUTPUT: 1=OK, 0=Don't Purge
46 N RESULT,X,DFN
47 S RESULT=1
48 ;-- if PTF record does not exist... exit
49 I '$D(^DGPT(PTF,0)) S RESULT=0 G SHUDEND
50 S DFN=$P($G(^DGPT(PTF,0)),U)
51 ;-- check if current inpatient
52 S X=$O(^DGPM("APTF",PTF,0)) I '$P($G(^DGPT(PTF,70)),U),X,X=$G(^DPT(DFN,.105)) S RESULT=0 G SHUDEND
53 ;-- check if discharge date is after end date
54 I $P($G(^DGPT(PTF,70)),U)>$P(DRANGE,U,2) S RESULT=0 G SHUDEND
55 ;-- check for entry in bill claims file
56 I $D(^DGCR(399,"APTF",PTF)) S RESULT=0 G SHUDEND
57 ;
58SHUDEND Q RESULT
59 ;
60CRTEMP ;-- This function will create a sort template containing the
61 ; items from the PTF File (#45) that should be Archived/Purged. The
62 ; name of the template will be derive from the date range selected.
63 ; Lastly, if items are selected, then an entry will be made in the
64 ; PTF Archive/Purge History File (#45.62).
65 ;
66 ; Sample File name DGPTAP89011391110201 = Archive PTF Sort Template
67 ; created for the date range:
68 ;
69 ; Jan 13, 1989 - Nov 2, 1991 - #1 created for that date range.
70 ; Note: if more then 1 entry is made for a date range then the last
71 ; 2 characters will be incremented. Max for date range = 99
72 ;
73 ;-- get date range, build file name, get next sequence number
74 N FNAME,OLFN,SEQNUM,DRANGE,TEMP,NUMREC
75 ;-- get date range
76 S DRANGE=$$SEL() G:DRANGE=U!($P(DRANGE,U)="")!($P(DRANGE,U,2)="") CRQ
77 ;-- build template name
78 S FNAME="DGPTAP"_$E(DRANGE,2,7)_$E($P(DRANGE,U,2),2,7)
79 ;-- determine correct sequence number
80 S SEQNUM=1,OLFN=FNAME F S OLFN=$O(^DIBT("B",OLFN)) Q:OLFN=""!(FNAME<$E(OLFN,1,18)) I FNAME=$E(OLFN,1,18) S SEQNUM=SEQNUM+1
81 S FNAME=FNAME_$S(SEQNUM<10:"0"_SEQNUM,1:SEQNUM)
82 ;-- add entry to sort template file
83 S DIC="^DIBT(",DIC(0)="LZ",X=FNAME,DIC("DR")="2///NOW;4///45;7///NOW"
84 K DD,DO D FILE^DICN S TEMP=+Y I 'Y W !,*7,">>> Error creating Sort Template ... Try again later." G CRQ
85 ;-- search File (#45), for the date range, if no entries del template
86 S NUMREC=$$SRCH("^DIBT("_TEMP_",1,",DRANGE)
87 I NUMREC=0 D G CRQ
88 . W !,*7,">>> No entries selected for "
89 . S Y=$P(DRANGE,U) X ^DD("DD") W Y," to "
90 . S Y=$P(DRANGE,U,2) X ^DD("DD") W Y,"."
91 . W !,*7,">>> Deleting Sort Template."
92 . S DIK="^DIBT(",DA=TEMP D ^DIK K DIK,DA
93 ;-- create historical entry in file #45.62
94 D CRHIS(FNAME,NUMREC,DRANGE)
95CRQ K DIC,DD,DO
96 Q
97 ;
98CRHIS(FNAME,NUMREC,DRANGE) ;-- This function will create an entry in the
99 ; PTF Archive/Purge History File (#45.62).
100 ;
101 ; INPUT : FNAME - Name of entry (same as search template)
102 ; NUMREC - Total number of records to process
103 ;
104 W !,">>> Creating PTF Archive/Purge History entry."
105 S DIC="^DGP(45.62,",DIC(0)="LZ",X=FNAME,DIC("DR")=".08///"_FNAME_";.09///^S X=NUMREC;.1///"_$P(DRANGE,U)_";.11///"_$P(DRANGE,U,2)
106 K DD,DO D FILE^DICN S TEMP=+Y
107 K DIC
108 Q
109 ;
110DELENTRY(FNAME) ;-- This function will delete the entry in the
111 ; the PTF Archive/Purge History file and the search
112 ; template.
113 ; INPUT : FNAME - History File to delete.
114 ;
115 N RECNUM
116 W *7,!,">>> Deleting PTF Archive/Purge History entry."
117 S RECNUM=$O(^DGP(45.62,"B",FNAME,0)) I 'RECNUM G DELENQ
118 S DA=$P(^DGP(45.62,RECNUM,0),U,8) I DA S DIK="^DIBT(" D ^DIK K DIK,DA
119 S DIK="^DGP(45.62,",DA=RECNUM D ^DIK K DIK,DA
120DELENQ Q
121 ;
Note: See TracBrowser for help on using the repository browser.