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