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

PSUDEM1.m

Go to the documentation of this file. 
  1. PSUDEM1 ;BIR/DAM - Patient Demographics Extract ; 20 DEC 2001
  1.  ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19
  1.  ;
  1.  ;DBIA's
  1.  ; Reference to file #27.11  supported by DBIA 2462
  1.  ; Reference to file 2       supported by DBIA 10035, 3504
  1.  ; Reference to file 200     supported by DBIA 10060
  1.  ; Reference to file 55      supported by DBIA 3502
  1.  ; Reference to file 4.3     supported by DBIA 2496, 10091
  1.  ; Reference to file 4       supported by DBIA 10090
  1.  ;
  1. EN ;EN   Routine control module
  1.  ;
  1.  D DAT
  1.  I $D(^XTMP("PSUMANL")) D DEM     ;Manual entry point  DAM
  1.  I $G(^XTMP("PSU_"_PSUJOB,"PSUPSUMFLAG")) D HL7    ;Auto entry point DAM
  1.  I '$D(^XTMP("PSU_"_PSUJOB,"PSUFLAG")) D XMD
  1.  K ^XTMP("PSU_"_PSUJOB,"PSUXMD")
  1.  ;
  1.  I $G(^XTMP("PSU_"_PSUJOB,"PSUPSUMFLAG"))=1 D
  1.  .S PSUOPTS="1,2,3,4,5,6,7,8,9,10,11"
  1.  .S PSUAUTO=1
  1.  ;
  1.  ;
  1.  D PULL^PSUCP
  1.  F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))=""
  1.  ;
  1.  I $D(PSUMOD(10)) D PDSSN^PSUDEM4  ;pt. demographics provider msg
  1.  ;
  1.  K ^XTMP("PSU_"_PSUJOB,"PSUPDFLAG")
  1.  K ^XTMP("PSU_"_PSUJOB,"PSUDM")
  1.  K ^XTMP("PSU_"_PSUJOB,"PSUDMX")
  1.  K PSUDMDFN,PSURAC,PSURDT
  1.  Q
  1.  ;
  1. HL7 ;This is the Patient Demographics extract that runs only when
  1.  ;the PSU PBM [AUTO] option is executed.  It captures demographic
  1.  ;information ONLY on new or updated patient.
  1.  ;
  1.  ; *** PSU*4.0*12 - BAJ -- added QUIT if NULL
  1.  F  S PSUSDT=$O(^PSUDEM("B",PSUSDT)) Q:PSUSDT=""  Q:PSUSDT>PSUEDT  D
  1.  . S I=""
  1.  . S I=$O(^PSUDEM("B",PSUSDT,I)) Q:I=""
  1.  . S DFN=$P(^PSUDEM(I,0),U,2)
  1.  . S ^XTMP("PSU"_PSUJOB,"REXMT",DFN)=""
  1.  K DFN
  1.  ;
  1.  S DFN=""
  1.  F  S (DFN,PSUDMDFN)=$O(^XTMP("PSU"_PSUJOB,"REXMT",DFN)) Q:DFN=""  D DEM1
  1.  ;
  1.  Q
  1.  ;
  1. DAT ;Date Module
  1.  ;
  1.  ;Date extract was run
  1.  S %H=$H
  1.  D YMD^%DTC                   ;Converts $H to FileMan format
  1.  ; ** S $P(^TMP("PSUDM",$J),U,3)=X    ;Set extract date in temp global
  1.  S PSURDT=X
  1.  ;
  1.  Q
  1.  ;
  1. INST ;EN  Place institution code sending report into temp global.
  1.  ;Institution Mailman info is in file 4.3 
  1.  ;
  1.  S X=$$VALI^PSUTL(4.3,1,217),PSUSNDR=+$$VAL^PSUTL(4,X,99)
  1.  S $P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)=PSUSNDR
  1.  S PSUSIT=PSUSNDR
  1.  ;
  1.  S X=PSUSNDR,DIC=40.8,DIC(0)="X",D="C" D IX^DIC ;**1
  1.  S X=+Y S PSUDIVNM=$$VAL^PSUTL(40.8,X,.01)
  1.  S $P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,2)=PSUDIVNM
  1.  Q
  1.  ;
  1. DEM ;PULL PATIENT DEMOGRAPHICS. This is run only when user selects
  1.  ;PSU PBM [MANUAL] option.  It gather patient demographic information
  1.  ;for all patients in the PATIENT file #2.
  1.  ;
  1.  ;N PSUREC    ;DAM TEST NEW CODE
  1.  N PSUREC
  1.  K PSUREC1,PSUREC2,PSUREC3,PSUREC4,PSUREC5,PSUREC6,PSUREC7
  1.  K PSUREC8,PSUREC9,PSUREC10,PSUREC11,PSUREC12,PSUREC13,PSUREC14
  1.  K PSUREC15,PSUDOD,VAEL,VADM
  1.  ;
  1.  S PSUNAM=0
  1.  F  S PSUNAM=$O(^DPT("B",PSUNAM)) Q:PSUNAM=""  D
  1.  .S PSUDMDFN=0
  1.  .F  S (DFN,PSUDMDFN)=$O(^DPT("B",PSUNAM,PSUDMDFN)) Q:PSUDMDFN=""  D DEM1
  1.  Q
  1.  ;
  1. DEM1 ;
  1.  K PSUREC,PSUREC1,PSUREC2,PSUREC3,PSUREC4,PSUREC5,PSUREC6,PSUREC7
  1.  K PSUREC8,PSUREC9,PSUREC10,PSUREC11,PSUREC12,PSUREC13,PSUREC14
  1.  K PSUREC15,PSUDOD,VAEL,VADM
  1.  S PSUDOD=$P($G(^DPT(PSUDMDFN,.35)),U,1) I PSUDOD,PSUDOD<2980701 Q
  1.  Q:'$D(^DPT(PSUDMDFN,0))  S PSUREC1=$G(^DPT(PSUDMDFN,0))
  1.  I $P(PSUREC1,U,21)=1 Q
  1.  I $E($P(PSUREC1,U,9),1,5)="00000" Q
  1.  D DEM^VADPT
  1.  D ELIG^VADPT
  1.  ;RUN DATE
  1.  S $P(PSUREC,U,3)=PSURDT
  1.  ;Gender
  1.  S PSUREC3=$TR($P(PSUREC1,U,2),"^","'"),$P(PSUREC,U,8)=PSUREC3
  1.  ;SSN
  1.  S PSUREC4=$TR($P(PSUREC1,U,9),"^","'"),$P(PSUREC,U,12)=PSUREC4
  1.  ;DOB
  1.  S PSUREC5=$TR($P(PSUREC1,U,3),"^","'"),$P(PSUREC,U,5)=PSUREC5
  1.  ;DT PT ENTERED IN FILE
  1.  S PSUREC6=$TR($P(PSUREC1,U,16),"^","'"),$P(PSUREC,U,16)=PSUREC6
  1.  S PSUREC7=$G(^PS(55,PSUDMDFN,0)),$P(PSUREC,U,17)=$TR($P(PSUREC7,U,7),"^","'")
  1.  ;Service Actual/Historical
  1.  S $P(PSUREC,U,18)=$TR($P(PSUREC7,U,8),"^","'")
  1.  ;PLACE "^" AT END OF RECORD
  1.  S $P(PSUREC,U,30)=""
  1.  ;SITE SENDING DATA
  1.  S $P(PSUREC,U,2)=PSUSNDR
  1.  ;RACE
  1.  S PSUREC8=$P($G(VADM(8)),U,2),$P(PSUREC,U,7)=PSUREC8
  1.  ;PRIMARY ELIG CODE
  1.  S PSUREC9=$P($G(VAEL(1)),U,2),$P(PSUREC,U,9)=PSUREC9
  1.  D PRIO
  1.  ;MEANS TEST STATUS
  1.  S PSUREC11=$P($G(VAEL(9)),U,2),$P(PSUREC,U,10)=PSUREC11
  1.  D MISC
  1.  ;FIND PATIENT ICN-VMP
  1.  D ICN
  1.  ;PATIENT CURRENT AGE
  1.  S PSUREC12=$G(VADM(4)),$P(PSUREC,U,6)=PSUREC12
  1.  D ETH
  1.  S ^XTMP("PSU_"_PSUJOB,"PSUDMX",PSUDMDFN)=$G(PSUREC)
  1.  Q
  1.  ;
  1. PRIO ;Pull Enrollment Priority
  1.  ;
  1.  S PSUEC=0
  1.  F  S PSUEC=$O(^DGEN(27.11,"C",PSUDMDFN,PSUEC)) Q:PSUEC=""  D
  1.  .S PSUREC10=$TR($P($G(^DGEN(27.11,PSUEC,0)),U,7),"^","'")
  1.  .I PSUREC10'="" S $P(PSUREC,U,11)=PSUREC10
  1.  Q
  1.  ;
  1. MISC ;Pulls miscellaneous additional info via EN^DIQ1 call
  1.  ;Pulls Date of Death, ICN, Primary Care Provider SSN,
  1.  ;Date patient first provided pharmacy care
  1.  ;
  1.  N PSUDATMP,PSUDDTMP,PSUDTMPA
  1.  ;
  1.  S PSUDTMPA=$$OUTPTPR^SDUTL3(PSUDMDFN)   ;Prov IEN^EXTERNAL VALUE in temp variable
  1.  S PSUDATMP=$P($G(PSUDTMPA),U)       ;Prov IEN
  1.  S $P(PSUREC,U,15)=PSUDATMP
  1.  I '$D(PSUDATMP)!PSUDATMP=0 S PSUDATMP=99999999999
  1.  S $P(PSUREC,U,14)=$$GET1^DIQ(200,PSUDATMP,9,"I")   ;Prov SSN
  1.  S $P(PSUREC,U,4)=$S(PSUDOD:PSUDOD\1,1:"")
  1.  Q
  1.  ;
  1. ICN ;Find patient ICN
  1.  ;VMP - OIFO BAY PINES;ELR;PSU*3.0*24
  1.  ;
  1.  N PSUICN,PSUICN1
  1.  S PSUICN=$$GETICN^MPIF001(PSUDMDFN) D
  1.  .I PSUICN'[-1 D
  1.  ..S $P(PSUREC,U,13)=PSUICN    ;ICN
  1.  Q
  1.  ;
  1. ETH ;Ethnicity and multiple race entries
  1.  ;
  1.  S PSUREC14=$P($G(VADM(11,1)),U,2),$P(PSUREC,U,19)=PSUREC14
  1.  ;
  1.  S PSURCE=0,C=20,$P(PSUREC,U,C)=""
  1.  F  S PSURCE=$O(VADM(12,PSURCE)) Q:PSURCE=""  D       ;Race multiple
  1.  .S PSURAC=$P($G(VADM(12,PSURCE)),U,2),$P(PSUREC,U,C)=PSURAC,C=C+1
  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,"PSUDMX",PSUAB)) Q:PSUAB=""  D
  1.  .M ^XTMP("PSU_"_PSUJOB,"PSUDM",PSUPL)=^XTMP("PSU_"_PSUJOB,"PSUDMX",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,"PSUDM",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 PDMAIL^PSUDEM5
  1.  D CONF
  1.  Q
  1. CONF ;Construct globals for confirmation message
  1.  ;
  1.  N PSUDIVIS
  1.  D INST
  1.  S PSUDIVIS=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)
  1.  S PSUSUB="PSU_"_PSUJOB
  1.  S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,7,"M")=PSUMC
  1.  S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,7,"L")=PSUTLC
  1.  Q
  1. REC ;EN If "^" is contained in any record, replace it with "'"
  1.  ;
  1.  I PSUREC["^" S PSUREC=$TR(PSUREC,"^","'")
  1.  Q