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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUDEM4 7286 printed Dec 13, 2024@02:27:46 Page 2
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
