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

PSUDEM2.m

Go to the documentation of this file.
  1. PSUDEM2 ;BIR/DAM - Outpatient Visits Extract ;1/23/09 3:10pm
  1. ;;4.0;PHARMACY BENEFITS MANAGEMENT;**15,19**;MARCH, 2005;Build 28
  1. ;
  1. ;DBIA's
  1. ; Reference to file 2 supported by DBIA 10035
  1. ; Reference to file 9000010.07 supported by DBIA 3094
  1. ; Reference to file 9000010 supported by DBIA 3512
  1. ; Reference to file 4.3 supported by DBIA 2496
  1. ; Reference to file 9000010.18 supported by DBIA 3560
  1. ; Reference to file 81 supported by DBIA 2815
  1. ; Reference to ICDEX Utility supported by DBIA 5747
  1. EN ;EN Called from PSUCP
  1. K ^XTMP("PSU_"_PSUJOB,"PSUOPV"),^XTMP("PSU_"_PSUJOB,"PSUTMP")
  1. K NONE
  1. NEW CPTDA,CPTNM,ICDXDA,ICDXNM,PSUICN,PSUSSN,PSUSUB,PSUTEDT
  1. NEW PSUVSTDT,PSUX,PSUY,PTSTAT,SEG,VCPTDA,XX,J
  1. D DAT1
  1. I '$D(^XTMP("PSU_"_PSUJOB,"PSUTMP")) D NODATA
  1. D XMD
  1. EX K ^XTMP("PSU_"_PSUJOB,"PSUPDFLAG")
  1. K ^XTMP("PSU_"_PSUJOB,"PSUOPV")
  1. K ^XTMP("PSU_"_PSUJOB,"PSUXMD")
  1. K ^XTMP("PSU_"_PSUJOB,"PSUTMP")
  1. Q
  1. ;
  1. ;
  1. DAT1 ;Find visits from V POV file that fall within the date range
  1. S PSUTEDT=PSUEDT
  1. S PSUDT=PSUSDT-1,PSUX=9999999-PSUDT,PSUY=9999999-PSUEDT N PSUEDT
  1. S PSUY=PSUSDT-.0001
  1. F S PSUY=$O(^AUPNVSIT("B",PSUY)) Q:PSUY'>0 Q:((PSUY\1)>PSUTEDT) D
  1. . S PSUVIEN=0 F S PSUVIEN=$O(^AUPNVSIT("B",PSUY,PSUVIEN)) Q:$G(PSUVIEN)'>0 D
  1. .. S PSUPT=$$VALI^PSUTL(9000010,PSUVIEN,.05)
  1. .. D DAT2
  1. Q
  1. DAT2 ;
  1. S PSUPOV=0 F S PSUPOV=$O(^AUPNVPOV("AD",PSUVIEN,PSUPOV)) Q:PSUPOV'>0 D
  1. .N PSUVIEN
  1. .S PSUVIEN=$P($G(^AUPNVPOV(PSUPOV,0)),U,3)
  1. .Q:PSUVIEN=""
  1. .Q:$D(^XTMP("PSU"_PSUJOB,"PSUOPV",PSUVIEN)) ; quit if visit psuvien already stored
  1. . D POVS
  1. .S PSUVSTDT=$P($G(^AUPNVSIT(PSUVIEN,0)),U)\1
  1. .S PSUSSN=$P(^DPT(PSUPT,0),U,9)
  1. .S PSUICN=$$GETICN^MPIF001(PSUPT)
  1. .I PSUICN[-1 S PSUICN=""
  1. .;PSU*4*15 Protect from empty 150 nodes
  1. .S PTSTAT=$P($G(^AUPNVSIT(PSUVIEN,150)),U,2),PTSTAT=$S(+PTSTAT:"I",1:"O")
  1. .D SET
  1. Q
  1. POVS ;several POVs can have same visit, work all when the first is found
  1. ;N PSUPOV
  1. N PSUPOV,ICDDATA
  1. ;PSU*4*15 move kills out of loop.
  1. K ALLICD,ALLICDX,ALLCPT,PSUCSYS
  1. S PSUPOV=0 F S PSUPOV=$O(^AUPNVPOV("AD",PSUVIEN,PSUPOV)) Q:PSUPOV'>0 D
  1. .;LOOP CPTs linked by visit
  1. .S VCPTDA=0 F S VCPTDA=$O(^AUPNVCPT("AD",PSUVIEN,VCPTDA)) Q:VCPTDA'>0 D
  1. ..; get/gather cpts
  1. ..S CPTDA=$P($G(^AUPNVCPT(VCPTDA,0)),U),CPTNM=$P($G(^ICPT(CPTDA,0)),U) S:$L(CPTNM) ALLCPT(CPTNM)=""
  1. ..;get/gather icds
  1. ..S PSUXDA=$P($G(^AUPNVCPT(VCPTDA,0)),U,5) I PSUXDA S ICDDATA=$$ICDDX^ICDEX(PSUXDA,,,"I"),ICDXNM=$P(ICDDATA,U,2)
  1. ..I $G(ICDXNM)]"" S ALLICDX($S($P(ICDDATA,U,20)=1:"9",$P(ICDDATA,U,20)=30:"10",1:"-null-"),ICDXNM)=""
  1. .;get original icd
  1. .S PSUXDA=$P($G(^AUPNVPOV(PSUPOV,0)),U) I PSUXDA S ICDDATA=$$ICDDX^ICDEX(PSUXDA,,,"I"),ICDXNM=$P(ICDDATA,U,2)
  1. .I $G(ICDXNM)]"" S ALLICDX($S($P(ICDDATA,U,20)=1:"9",$P(ICDDATA,U,20)=30:"10",1:"-null-"),ICDXNM)=""
  1. Q
  1. SET ; Set segment
  1. ;Figure Code System for SEG
  1. I $D(ALLICDX("9")),($D(ALLICDX("10"))) S PSUCSYS="U"
  1. I '$D(ALLICDX("9")),($D(ALLICDX("10"))) S PSUCSYS="10"
  1. I $D(ALLICDX("9")),('$D(ALLICDX("10"))) S PSUCSYS="9"
  1. F I="9","10","-null-" S J="" F S J=$O(ALLICDX(I,J)) Q:J="" S ALLICD(J)=""
  1. I '$D(ALLICD),'$D(ALLCPT) Q ;ensure visit has either CPT or ICD
  1. ;assemble elements and set
  1. S SEG=U_PSUSNDR_U_PTSTAT_U_PSUVSTDT_U_PSUSSN_U_PSUICN_U
  1. I $D(ALLICD) S ICDXNM="" F I=7:1:16 S ICDXNM=$O(ALLICD(ICDXNM)) Q:ICDXNM="" S $P(SEG,U,I)=ICDXNM
  1. I $D(ALLCPT) S CPTNM="" F J=17:1:26 S CPTNM=$O(ALLCPT(CPTNM)) Q:CPTNM="" S $P(SEG,U,J)=CPTNM
  1. S ($P(SEG,U,27),ICDXNM,CPTNM)=""
  1. S $P(SEG,U,$L(SEG,U))=$G(PSUCSYS,"")
  1. S ^XTMP("PSU_"_PSUJOB,"PSUTMP",PSUVIEN)=SEG
  1. Q
  1. ;
  1. XMD ;Format mailman message and send.
  1. S PSUAB=0
  1. F PSUPL=1:1 S PSUAB=$O(^XTMP("PSU_"_PSUJOB,"PSUTMP",PSUAB)) Q:PSUAB'>0 S XX=^(PSUAB) D
  1. . S ^XTMP("PSU_"_PSUJOB,"PSUOPV",PSUPL)=XX
  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,"PSUOPV",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. TLC ; 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 OPV^PSUDEM5
  1. D CONF
  1. Q
  1. CONF ;Construct globals for confirmation message
  1. ;
  1. I $G(NONE) S PSUTLC=0
  1. N PSUDIVIS
  1. S PSUDIVIS=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)
  1. S PSUSUB="PSU_"_PSUJOB
  1. S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,8,"M")=PSUMC
  1. S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,8,"L")=PSUTLC
  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. REC ;EN If "^" is contained in any record, replace it with "'"
  1. ;
  1. I PSUREC["^" S PSUREC=$TR(PSUREC,"^","'")
  1. Q