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