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

DGPTAPSL.m

Go to the documentation of this file. 
  1. DGPTAPSL ;MTC/ALB - PTF Archive and Purge Selection Routines; 9/11/92
  1.  ;;5.3;Registration;**31,1015**;Aug 13, 1993;Build 21
  1.  ;
  1. SEL() ;-- the routine will get the date range for the a/p process
  1.  N SDATE,EDATE,Y
  1.  S (SDATE,EDATE)=""
  1.  ;-- get oldest record on file
  1.  S Y=$O(^DGPT("AF",0)) D DD^%DT W !,"The oldest PTF record on file is from ",Y,"."
  1.  S DIR(0)="D^:"_$$MAXDT(),DIR("A")="Please enter the date to begin search"
  1.  D ^DIR
  1.  G:$D(DIRUT) SELQ S SDATE=Y
  1.  S DIR(0)="D^"_Y_":"_$$MAXDT(),DIR("A")="Please enter the date to end search"
  1.  D ^DIR
  1.  G:$D(DIRUT) SELQ S EDATE=Y
  1. SELQ Q SDATE_"^"_EDATE
  1.  ;
  1. MAXDT() ;-- This function will return the lastest date allowable for
  1.  ;purge. The date is based on the current FY - X; where X is
  1.  ;number of years determined by VACO.
  1.  ;  OUTPUT - date in FM format
  1.  N DATE,YEARS
  1.  S YEARS=3,DATE=""
  1.  D NOW^%DTC
  1.  ;-- get current FY
  1.  I %I(1)>9,%I(1)<13 S DATE=%I(3)+1
  1.  I %I(1)>0,%I(1)<10 S DATE=%I(3)
  1.  ;-- adjust max date by YEARS
  1.  S DATE=(DATE-YEARS)_"0930"
  1.  K %I,X
  1.  Q DATE
  1.  ;
  1. SRCH(GLB,DRANGE) ;-- search PTF file by adm date
  1.  ; INPUT: GLB    - Global to load entries ex. "^TMP("MATT",$J,"
  1.  ;        DRANGE - start date ^ end date in FM format
  1.  ;        
  1.  ; OUTPUT: Total # of entires loaded into GLB
  1.  N SDATE,EDATE,PDATE,NREC,PTF
  1.  S NREC=0,SDATE=$P(DRANGE,U),EDATE=$P(DRANGE,U,2)
  1.  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
  1.  Q NREC
  1.  ;
  1. SHUDADD(PTF,DRANGE) ;-- routine to determin if the PTF records should be added to purge
  1.  ; INPUT : PTF - record to check
  1.  ;         DRANGE - start and end date of search
  1.  ; OUTPUT: 1=OK, 0=Don't Purge
  1.  N RESULT,X,DFN
  1.  S RESULT=1
  1.  ;-- if PTF record does not exist... exit
  1.  I '$D(^DGPT(PTF,0)) S RESULT=0 G SHUDEND
  1.  S DFN=$P($G(^DGPT(PTF,0)),U)
  1.  ;-- check if current inpatient
  1.  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
  1.  ;-- check if discharge date is after end date
  1.  I $P($G(^DGPT(PTF,70)),U)>$P(DRANGE,U,2) S RESULT=0 G SHUDEND
  1.  ;-- check for entry in bill claims file
  1.  I $D(^DGCR(399,"APTF",PTF)) S RESULT=0 G SHUDEND
  1.  ;
  1. SHUDEND Q RESULT
  1.  ;
  1. CRTEMP ;-- This function will create a sort template containing the
  1.  ; items from the PTF File (#45) that should be Archived/Purged. The
  1.  ; name of the template will be derive from the date range selected.
  1.  ; Lastly, if items are selected, then an entry will be made in the
  1.  ; PTF Archive/Purge History File (#45.62).
  1.  ;
  1.  ;  Sample File name DGPTAP89011391110201 = Archive PTF Sort Template 
  1.  ; created for the date range:
  1.  ;
  1.  ;   Jan 13, 1989 - Nov 2, 1991 - #1 created for that date range.
  1.  ; Note: if more then 1 entry is made for a date range then the last
  1.  ;       2 characters will be incremented. Max for date range = 99
  1.  ;
  1.  ;-- get date range, build file name, get next sequence number
  1.  N FNAME,OLFN,SEQNUM,DRANGE,TEMP,NUMREC
  1.  ;-- get date range
  1.  S DRANGE=$$SEL() G:DRANGE=U!($P(DRANGE,U)="")!($P(DRANGE,U,2)="") CRQ
  1.  ;-- build template name
  1.  S FNAME="DGPTAP"_$E(DRANGE,2,7)_$E($P(DRANGE,U,2),2,7)
  1.  ;-- determine correct sequence number
  1.  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
  1.  S FNAME=FNAME_$S(SEQNUM<10:"0"_SEQNUM,1:SEQNUM)
  1.  ;-- add entry to sort template file
  1.  S DIC="^DIBT(",DIC(0)="LZ",X=FNAME,DIC("DR")="2///NOW;4///45;7///NOW"
  1.  K DD,DO D FILE^DICN S TEMP=+Y I 'Y W !,*7,">>> Error creating Sort Template ... Try again later." G CRQ
  1.  ;-- search File (#45), for the date range, if no entries del template
  1.  S NUMREC=$$SRCH("^DIBT("_TEMP_",1,",DRANGE)
  1.  I NUMREC=0 D  G CRQ
  1.  . W !,*7,">>> No entries selected for "
  1.  . S Y=$P(DRANGE,U) X ^DD("DD") W Y," to "
  1.  . S Y=$P(DRANGE,U,2) X ^DD("DD") W Y,"."
  1.  . W !,*7,">>> Deleting Sort Template."
  1.  . S DIK="^DIBT(",DA=TEMP D ^DIK K DIK,DA
  1.  ;-- create historical entry in file #45.62
  1.  D CRHIS(FNAME,NUMREC,DRANGE)
  1. CRQ K DIC,DD,DO
  1.  Q
  1.  ;
  1. CRHIS(FNAME,NUMREC,DRANGE) ;-- This function will create an entry in the 
  1.  ; PTF Archive/Purge History File (#45.62). 
  1.  ;
  1.  ;    INPUT :  FNAME - Name of entry (same as search template)
  1.  ;            NUMREC - Total number of records to process
  1.  ;  
  1.  W !,">>> Creating PTF Archive/Purge History entry."
  1.  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)
  1.  K DD,DO D FILE^DICN S TEMP=+Y
  1.  K DIC
  1.  Q
  1.  ;
  1. DELENTRY(FNAME) ;-- This function will delete the entry in the
  1.  ; the PTF Archive/Purge History file and the search
  1.  ; template.
  1.  ;   INPUT : FNAME - History File to delete.
  1.  ;
  1.  N RECNUM
  1.  W *7,!,">>> Deleting PTF Archive/Purge History entry."
  1.  S RECNUM=$O(^DGP(45.62,"B",FNAME,0)) I 'RECNUM G DELENQ
  1.  S DA=$P(^DGP(45.62,RECNUM,0),U,8) I DA S DIK="^DIBT(" D ^DIK K DIK,DA
  1.  S DIK="^DGP(45.62,",DA=RECNUM D ^DIK K DIK,DA
  1. DELENQ Q
  1.  ;