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

PSUDEM7.m

Go to the documentation of this file. 
  1. PSUDEM7 ;BIR/DAM - Inpatient PTF Record Extract ;20 DEC 2001
  1.  ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
  1.  ;
  1.  ;DBIA's
  1.  ; Reference to file 2    supported by DBIA 10035
  1.  ; Reference to file 4.3  supported by DBIA 2496
  1.  ; Reference to file 45   supported by DBIA 3511
  1.  ;
  1. EN ;EN
  1.  D DAT
  1.  D EN^PSUDEM8    ;Gather ICD9 codes
  1.  I '$D(^XTMP("PSU_"_PSUJOB,"PSUIPV")) D NODATA
  1.  D XMD
  1.  K ^XTMP("PSU_"_PSUJOB,"PSUIPV")
  1.  K ^XTMP("PSU_"_PSUJOB,"PSUXMD")
  1.  Q
  1.  ;
  1. DAT ;Find discharge dates that fall within the extract date range
  1.  ;as well as discharge dates within the 30 days prior to day 1 of
  1.  ;of the extract date range.
  1.  ;
  1.  S PSUDD=0
  1.  F  S PSUDD=$O(^DGPT("ADS",PSUDD)) Q:'PSUDD  D
  1.  .S PSUDDT=$E(PSUDD,1,7)
  1.  .S X1=PSUSDT
  1.  .S X2=(-30)
  1.  .D C^%DTC
  1.  .S PSUSDT1=X              ;Date 30 days prior to start date
  1.  .I (PSUDDT>PSUSDT1)!(PSUDDT=PSUSDT1)&(PSUDDT<PSUEDT)!(PSUDDT=PSUEDT) D
  1.  ..S ^XTMP("PSU_"_PSUJOB,"PSUDM",PSUDDT)=""
  1.  ..S PSUIEN=0
  1.  ..F  S PSUIEN=$O(^DGPT("ADS",PSUDD,PSUIEN)) Q:'PSUIEN  D
  1.  ...S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,5)=PSUDDT        ;Discharge Date
  1.  ...N PSUDT
  1.  ...S PSUDT=$P($G(^DGPT(PSUIEN,0)),U,2)
  1.  ...S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,4)=$E(PSUDT,1,7)  ;Admit date
  1.  ...D INST^PSUDEM1
  1.  ...S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,2)=PSUSIT         ;SITE
  1.  ...S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,3)=PSUSIT_PSUIEN  ;Unique PTF ID
  1.  ...D SSNICN
  1.  Q
  1.  ;
  1. SSNICN ;Find patient Admission date, SSN and ICN for inpatient record
  1.  ;VMP - OIFO BAY PINES;ELR;PSU*3.0*24
  1.  ;
  1.  N PSUPT,PSUICN,PSUICN1
  1.  S PSUPT=$P($G(^DGPT(PSUIEN,0)),U)     ;Pointer to patient file
  1.  ;
  1.  N PSUREC
  1.  I PSUPT D
  1.  .S PSUREC=$P($G(^DPT(PSUPT,0)),U,9) D REC D
  1.  ..S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,6)=PSUREC     ;Pt SSN
  1.  .S PSUICN=$$GETICN^MPIF001(PSUPT) D
  1.  ..I PSUICN'[-1 D
  1.  ...S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,7)=PSUICN   ;ICN
  1.  Q
  1.  ;
  1. REC ;If "^" is contained in any record, replace it with (')
  1.  ;
  1.  I PSUREC["^" S PSUREC=$TR(PSUREC,"^","'")
  1.  Q
  1.  ;
  1. NODATA ;Generate a 'No Data' message if there is no data in the extract
  1.  ;
  1.  S NONE=1
  1.  M PSUXMYH=PSUXMYS1
  1.  S PSUM=1
  1.  S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUM,1)="No data to report"
  1.  Q
  1.  ;
  1. XMD ;Format mailman message and send.
  1.  ;
  1.  S PSUAB=0,PSUPL=1
  1.  F  S PSUAB=$O(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUAB)) Q:PSUAB=""  D
  1.  .M ^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUPL)=^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUAB)  ;Global numerical order
  1.  .S PSUPL=PSUPL+1
  1.  ;
  1.  NEW PSUMAX,PSULC,PSUTMC,PSUTLC,PSUMC
  1.  S PSUMAX=$$VAL^PSUTL(4.3,1,8.3)
  1.  S PSUMAX=$S(PSUMAX="":10000,PSUMAX>10000:10000,1:PSUMAX)
  1.  S PSUMC=1,PSUMLC=0
  1.  F PSULC=1:1 S X=$G(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSULC)) Q:X=""  D
  1.  .S PSUMLC=PSUMLC+1
  1.  .I PSUMLC>PSUMAX S PSUMC=PSUMC+1,PSUMLC=0,PSULC=PSULC-1 Q  ; +  message
  1.  .I $L(X)<235 S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=X Q
  1.  .F I=235:-1:1 S Z=$E(X,I) Q:Z="^"
  1.  .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=$E(X,1,I)
  1.  .S PSUMLC=PSUMLC+1
  1.  .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)="*"_$E(X,I+1,999)
  1.  ;
  1.  ;   Count Lines sent
  1.  S PSUTLC=0
  1.  F PSUM=1:1:PSUMC S X=$O(^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUM,""),-1),PSUTLC=PSUTLC+X
  1.  ;
  1.  F PSUM=1:1:PSUMC D PTF^PSUDEM5
  1.  D CONF
  1.  Q
  1. CONF ;Construct globals for confirmation message
  1.  ;
  1.  ;D INST^PSUDEM1
  1.  I $G(NONE) S PSUTLC=0
  1.  N PSUDIVIS
  1.  ;S PSUDIVIS=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)
  1.  S PSUDIVIS=PSUSNDR
  1.  S PSUSUB="PSU_"_PSUJOB
  1.  S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,9,"M")=PSUMC
  1.  S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,9,"L")=PSUTLC
  1.  Q