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

PSUDEM4.m

Go to the documentation of this file.
  1. PSUDEM4 ;BIR/DAM - Provider Extract ; 4/26/07 4:38pm
  1. ;;4.0;PHARMACY BENEFITS MANAGEMENT;**8,12**;MARCH, 2005;Build 19
  1. ;
  1. ;DBIA'S
  1. ; Reference to file 200 supported by DBIA 10060
  1. ; Reference to file 7 supported by DBIA 2495
  1. ; Reference to file 49 supported by DBIA 432
  1. ; Reference to file 8932.1 supported by DBIA 2091
  1. ; Reference to file 4.2 supported by DBIA 2496
  1. ;
  1. EN ;Entry point for gathering all provider information from IV, UD, Rx,
  1. ;and PD modules.
  1. ;
  1. N PSUREC
  1. S ^XTMP("PSU_"_PSUJOB,"PSUFLAG")=""
  1. ;
  1. D PULL^PSUCP
  1. F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))=""
  1. ;
  1. I '$D(PSUMOD(7)) D EN^PSUDEM1
  1. I '$D(PSUMOD(1)) D EN^PSUV0
  1. I '$D(PSUMOD(2)) D EN^PSUUD0
  1. I '$D(PSUMOD(4)) D
  1. .S ^XTMP("PSU_"_PSUJOB,"PSUOPFLG")="" ;Set flag
  1. .D EN^PSUOP0
  1. M ^XTMP("PSU_"_PSUJOB,"PSUPROM")=^XTMP("PSU_"_PSUJOB,"PSUPROV")
  1. ;
  1. D XMD
  1. D EN^PSUSUM1 ;compose provider summary report and mail it.
  1. K ^XTMP("PSU_"_PSUJOB,"PSUFLAG")
  1. Q
  1. ;
  1. PDSSN ;EN Called from PSUDEM1
  1. ;Find provider SSN and IEN present in the patient demographics
  1. ;extract. Note that this is the primary care provider.
  1. ;
  1. S PSUT=0
  1. F S PSUT=$O(^XTMP("PSU_"_PSUJOB,"PSUDM",PSUT)) Q:'PSUT D
  1. .N PSUIEN,PSUSSN1
  1. .S PSUIEN=$P($G(^XTMP("PSU_"_PSUJOB,"PSUDM",PSUT)),U,15) I 'PSUIEN S PSUIEN="UNK"
  1. .D FAC
  1. .D PNAM
  1. .S PSUSSN1=$P($G(^XTMP("PSU_"_PSUJOB,"PSUDM",PSUT)),U,14) I 'PSUSSN1 S PSUSSN1=""
  1. .S PSUREC=PSUSSN1 D REC^PSUDEM2
  1. .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,3)=PSUREC ;Dem Prov SSN
  1. .S PSUREC=PSUIEN D REC^PSUDEM2
  1. .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,4)=PSUREC D ;Dem Prov ICN
  1. ..I PSUREC="UNK" K ^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN)
  1. Q
  1. ;
  1. UDSSN ;EN Called from PROV^PSUUD1. Find provider SSN and IEN in the unit
  1. ;dose extract
  1. ;
  1. S PSUIEN=0,PSUVSSN1=0
  1. F S PSUVSSN1=$O(^XTMP("PSU_"_PSUJOB,"PSUPDR",PSUVSSN1)) Q:PSUVSSN1="" D
  1. .F S PSUIEN=$O(^XTMP("PSU_"_PSUJOB,"PSUPDR",PSUVSSN1,PSUIEN)) Q:PSUIEN="" D
  1. ..D FAC
  1. ..S PSUREC=PSUVSSN1 D REC^PSUDEM1 D
  1. ...I PSUREC=999999999 S PSUREC=""
  1. ...S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,3)=PSUREC ;UD Prov SSN
  1. ..S PSUREC=PSUIEN D REC^PSUDEM2
  1. ..S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,4)=PSUREC ;UD Prov IEN
  1. ..D PNAM
  1. Q
  1. ;
  1. IVSSN ;EN Called from PSUIV1. Gives Provider within date range of extract
  1. ;
  1. D UDSSN
  1. Q
  1. ;
  1. OPSSN ;EN Called from PSUOP0. Gives prescription Provider
  1. ;
  1. D UDSSN
  1. Q
  1. FAC ;Find provider station number. Places that info in each record.
  1. ;
  1. ;D INST^PSUDEM1
  1. S $P(^TMP("PSUPROV",$J),U,2)=PSUSNDR
  1. M ^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN)=^TMP("PSUPROV",$J)
  1. Q
  1. ;
  1. PNAM ;Find the provider's name.
  1. ;
  1. N PSUCLP,PSUSS,PSUSP
  1. ;
  1. ;Find provider name
  1. S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,9)=$$GET1^DIQ(200,PSUIEN,.01,"I")
  1. ;
  1. S PSUCLP=$$GET1^DIQ(200,PSUIEN,53.5,"I") D CLASS ;Provider pointer
  1. S PSUSS=$$GET1^DIQ(200,PSUIEN,29,"I") D SS ;Service Sctn ptr
  1. ;
  1. S PSUD1=999
  1. S PSUD1=$O(^VA(200,PSUIEN,"USC1",PSUD1),-1) ;Find last subscript
  1. I PSUD1'="" D
  1. .S PSUSP=$$GET1^DIQ(200.05,PSUD1_","_PSUIEN_",",.01,"I") ;Specialty
  1. .D SPEC
  1. I PSUD1="" D
  1. .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)=""
  1. .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)=""
  1. Q
  1. ;
  1. CLASS ;Find provider class
  1. ;
  1. I '$D(PSUCLP) S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)="" Q
  1. I PSUCLP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)=""
  1. I PSUCLP'="" D
  1. .N PSUA
  1. .S PSUA=$P($G(^DIC(7,PSUCLP,0)),U,2)
  1. .I PSUA']"" S PSUA=$P($G(^DIC(7,PSUCLP,0)),U,1)
  1. .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)=PSUA ;Prov class
  1. .K PSUA
  1. Q
  1. ;
  1. SS ;Find Provider Service/Section
  1. ;
  1. N PSUTMP
  1. ;
  1. I PSUSS="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,6)=""
  1. I PSUSS'="" S PSUTMP=1 D
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["AMBU" PSUTMP="AMB"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["ANESTH" PSUTMP="ANES"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["CARDIO" PSUTMP="CV"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["PHARM" PSUTMP="CPHAR"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["DENT" PSUTMP="DDS"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["MEDIC" PSUTMP="MED"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["INTERMED" PSUTMP="IM"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["NUCLEAR" PSUTMP="NUM"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["NURSING" PSUTMP="RN"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["ORTHOPED" PSUTMP="ORTHO"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["PSYCHIA" PSUTMP="PSY"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["MENTAL" PSUTMP="PSY"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["PRIMARY" PSUTMP="AMB"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["CBOC" PSUTMP="AMB"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["OPHTH" PSUTMP="OPH"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["PULM" PSUTMP="PUL"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["RADIOL" PSUTMP="RAD"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["SURG" PSUTMP="SUR"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["UROLOG" PSUTMP="U"
  1. .S:$P($G(^DIC(49,PSUSS,0)),U)["NEUROL" PSUTMP="NEUR"
  1. .S PSUREC=$G(PSUTMP) D REC^PSUDEM2
  1. .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,6)=$G(PSUREC) ;Prov Serv/Sec
  1. Q
  1. ;
  1. SPEC ;Find provider specialty and sub-specialty
  1. ;
  1. I PSUSP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)=""
  1. I PSUSP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)=""
  1. I PSUSP'="" D
  1. .S PSUREC=$P($G(^USC(8932.1,PSUSP,0)),U,2) D REC^PSUDEM2
  1. .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)=PSUREC D ;Speclty
  1. ..I $P(^USC(8932.1,PSUSP,0),U,2)="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)=""
  1. .S PSUREC=$P($G(^USC(8932.1,PSUSP,0)),U,3) D REC^PSUDEM2
  1. .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)=PSUREC D ;Subspecl
  1. ..I $P(^USC(8932.1,PSUSP,0),U,3)="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)=""
  1. ;
  1. Q
  1. ;
  1. XMD ;Format mailman message and send.
  1. ;
  1. S PSUAA=0
  1. F S PSUAA=$O(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAA)) Q:PSUAA="" D
  1. .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAA),U,9)="" ;Remove provider name
  1. ;
  1. ;Remove space in piece 8
  1. S PSUAB=0
  1. F S PSUAB=$O(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAB)) Q:PSUAB="" D
  1. .I $P(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAB),U,8)=" " D
  1. ..S $P(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAB),U,8)=""
  1. ;
  1. S PSUAC=0,PSUPL=1
  1. F S PSUAC=$O(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAC)) Q:PSUAC="" D
  1. .M ^TMP("PSUPROM",$J,PSUPL)=^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAC) ;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(^TMP("PSUPROM",$J,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. F PSUM=1:1:PSUMC D PROV^PSUDEM5
  1. D CONF
  1. Q
  1. CONF ;Construct globals for confirmation message
  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. D INST^PSUDEM1
  1. N PSUDIVIS
  1. S PSUDIVIS=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)
  1. S PSUSUB="PSU_"_PSUJOB
  1. S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,10,"M")=PSUMC
  1. S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,10,"L")=PSUTLC
  1. Q