- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUDEM4.m
r613 r623 1 PSUDEM4 ;BIR/DAM - Provider Extract ; 4/26/07 4:38pm 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**8,12**;MARCH, 2005;Build 19 3 ; 4 ;DBIA'S 5 ; Reference to file 200 supported by DBIA 10060 6 ; Reference to file 7 supported by DBIA 2495 7 ; Reference to file 49 supported by DBIA 432 8 ; Reference to file 8932.1 supported by DBIA 2091 9 ; Reference to file 4.2 supported by DBIA 2496 10 ; 11 EN ;Entry point for gathering all provider information from IV, UD, Rx, 12 ;and PD modules. 13 ; 14 N PSUREC 15 S ^XTMP("PSU_"_PSUJOB,"PSUFLAG")="" 16 ; 17 D PULL^PSUCP 18 F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))="" 19 ; 20 I '$D(PSUMOD(7)) D EN^PSUDEM1 21 I '$D(PSUMOD(1)) D EN^PSUV0 22 I '$D(PSUMOD(2)) D EN^PSUUD0 23 I '$D(PSUMOD(4)) D 24 .S ^XTMP("PSU_"_PSUJOB,"PSUOPFLG")="" ;Set flag 25 .D EN^PSUOP0 26 M ^XTMP("PSU_"_PSUJOB,"PSUPROM")=^XTMP("PSU_"_PSUJOB,"PSUPROV") 27 ; 28 D XMD 29 D EN^PSUSUM1 ;compose provider summary report and mail it. 30 K ^XTMP("PSU_"_PSUJOB,"PSUFLAG") 31 Q 32 ; 33 PDSSN ;EN Called from PSUDEM1 34 ;Find provider SSN and IEN present in the patient demographics 35 ;extract. Note that this is the primary care provider. 36 ; 37 S PSUT=0 38 F S PSUT=$O(^XTMP("PSU_"_PSUJOB,"PSUDM",PSUT)) Q:'PSUT D 39 .N PSUIEN,PSUSSN1 40 .S PSUIEN=$P($G(^XTMP("PSU_"_PSUJOB,"PSUDM",PSUT)),U,15) I 'PSUIEN S PSUIEN="UNK" 41 .D FAC 42 .D PNAM 43 .S PSUSSN1=$P($G(^XTMP("PSU_"_PSUJOB,"PSUDM",PSUT)),U,14) I 'PSUSSN1 S PSUSSN1="" 44 .S PSUREC=PSUSSN1 D REC^PSUDEM2 45 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,3)=PSUREC ;Dem Prov SSN 46 .S PSUREC=PSUIEN D REC^PSUDEM2 47 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,4)=PSUREC D ;Dem Prov ICN 48 ..I PSUREC="UNK" K ^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN) 49 Q 50 ; 51 UDSSN ;EN Called from PROV^PSUUD1. Find provider SSN and IEN in the unit 52 ;dose extract 53 ; 54 S PSUIEN=0,PSUVSSN1=0 55 F S PSUVSSN1=$O(^XTMP("PSU_"_PSUJOB,"PSUPDR",PSUVSSN1)) Q:PSUVSSN1="" D 56 .F S PSUIEN=$O(^XTMP("PSU_"_PSUJOB,"PSUPDR",PSUVSSN1,PSUIEN)) Q:PSUIEN="" D 57 ..D FAC 58 ..S PSUREC=PSUVSSN1 D REC^PSUDEM1 D 59 ...I PSUREC=999999999 S PSUREC="" 60 ...S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,3)=PSUREC ;UD Prov SSN 61 ..S PSUREC=PSUIEN D REC^PSUDEM2 62 ..S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,4)=PSUREC ;UD Prov IEN 63 ..D PNAM 64 Q 65 ; 66 IVSSN ;EN Called from PSUIV1. Gives Provider within date range of extract 67 ; 68 D UDSSN 69 Q 70 ; 71 OPSSN ;EN Called from PSUOP0. Gives prescription Provider 72 ; 73 D UDSSN 74 Q 75 FAC ;Find provider station number. Places that info in each record. 76 ; 77 ;D INST^PSUDEM1 78 S $P(^TMP("PSUPROV",$J),U,2)=PSUSNDR 79 M ^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN)=^TMP("PSUPROV",$J) 80 Q 81 ; 82 PNAM ;Find the provider's name. 83 ; 84 N PSUCLP,PSUSS,PSUSP 85 ; 86 ;Find provider name 87 S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,9)=$$GET1^DIQ(200,PSUIEN,.01,"I") 88 ; 89 S PSUCLP=$$GET1^DIQ(200,PSUIEN,53.5,"I") D CLASS ;Provider pointer 90 S PSUSS=$$GET1^DIQ(200,PSUIEN,29,"I") D SS ;Service Sctn ptr 91 ; 92 S PSUD1=999 93 S PSUD1=$O(^VA(200,PSUIEN,"USC1",PSUD1),-1) ;Find last subscript 94 I PSUD1'="" D 95 .S PSUSP=$$GET1^DIQ(200.05,PSUD1_","_PSUIEN_",",.01,"I") ;Specialty 96 .D SPEC 97 I PSUD1="" D 98 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)="" 99 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)="" 100 Q 101 ; 102 CLASS ;Find provider class 103 ; 104 I '$D(PSUCLP) S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)="" Q 105 I PSUCLP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)="" 106 I PSUCLP'="" D 107 .N PSUA 108 .S PSUA=$P($G(^DIC(7,PSUCLP,0)),U,2) 109 .I PSUA']"" S PSUA=$P($G(^DIC(7,PSUCLP,0)),U,1) 110 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)=PSUA ;Prov class 111 .K PSUA 112 Q 113 ; 114 SS ;Find Provider Service/Section 115 ; 116 N PSUTMP 117 ; 118 I PSUSS="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,6)="" 119 I PSUSS'="" S PSUTMP=1 D 120 .S:$P($G(^DIC(49,PSUSS,0)),U)["AMBU" PSUTMP="AMB" 121 .S:$P($G(^DIC(49,PSUSS,0)),U)["ANESTH" PSUTMP="ANES" 122 .S:$P($G(^DIC(49,PSUSS,0)),U)["CARDIO" PSUTMP="CV" 123 .S:$P($G(^DIC(49,PSUSS,0)),U)["PHARM" PSUTMP="CPHAR" 124 .S:$P($G(^DIC(49,PSUSS,0)),U)["DENT" PSUTMP="DDS" 125 .S:$P($G(^DIC(49,PSUSS,0)),U)["MEDIC" PSUTMP="MED" 126 .S:$P($G(^DIC(49,PSUSS,0)),U)["INTERMED" PSUTMP="IM" 127 .S:$P($G(^DIC(49,PSUSS,0)),U)["NUCLEAR" PSUTMP="NUM" 128 .S:$P($G(^DIC(49,PSUSS,0)),U)["NURSING" PSUTMP="RN" 129 .S:$P($G(^DIC(49,PSUSS,0)),U)["ORTHOPED" PSUTMP="ORTHO" 130 .S:$P($G(^DIC(49,PSUSS,0)),U)["PSYCHIA" PSUTMP="PSY" 131 .S:$P($G(^DIC(49,PSUSS,0)),U)["MENTAL" PSUTMP="PSY" 132 .S:$P($G(^DIC(49,PSUSS,0)),U)["PRIMARY" PSUTMP="AMB" 133 .S:$P($G(^DIC(49,PSUSS,0)),U)["CBOC" PSUTMP="AMB" 134 .S:$P($G(^DIC(49,PSUSS,0)),U)["OPHTH" PSUTMP="OPH" 135 .S:$P($G(^DIC(49,PSUSS,0)),U)["PULM" PSUTMP="PUL" 136 .S:$P($G(^DIC(49,PSUSS,0)),U)["RADIOL" PSUTMP="RAD" 137 .S:$P($G(^DIC(49,PSUSS,0)),U)["SURG" PSUTMP="SUR" 138 .S:$P($G(^DIC(49,PSUSS,0)),U)["UROLOG" PSUTMP="U" 139 .S:$P($G(^DIC(49,PSUSS,0)),U)["NEUROL" PSUTMP="NEUR" 140 .S PSUREC=$G(PSUTMP) D REC^PSUDEM2 141 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,6)=$G(PSUREC) ;Prov Serv/Sec 142 Q 143 ; 144 SPEC ;Find provider specialty and sub-specialty 145 ; 146 I PSUSP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)="" 147 I PSUSP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)="" 148 I PSUSP'="" D 149 .S PSUREC=$P($G(^USC(8932.1,PSUSP,0)),U,2) D REC^PSUDEM2 150 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)=PSUREC D ;Speclty 151 ..I $P(^USC(8932.1,PSUSP,0),U,2)="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)="" 152 .S PSUREC=$P($G(^USC(8932.1,PSUSP,0)),U,3) D REC^PSUDEM2 153 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)=PSUREC D ;Subspecl 154 ..I $P(^USC(8932.1,PSUSP,0),U,3)="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)="" 155 ; 156 Q 157 ; 158 XMD ;Format mailman message and send. 159 ; 160 S PSUAA=0 161 F S PSUAA=$O(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAA)) Q:PSUAA="" D 162 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAA),U,9)="" ;Remove provider name 163 ; 164 ;Remove space in piece 8 165 S PSUAB=0 166 F S PSUAB=$O(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAB)) Q:PSUAB="" D 167 .I $P(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAB),U,8)=" " D 168 ..S $P(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAB),U,8)="" 169 ; 170 S PSUAC=0,PSUPL=1 171 F S PSUAC=$O(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAC)) Q:PSUAC="" D 172 .M ^TMP("PSUPROM",$J,PSUPL)=^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAC) ;numerical order 173 .S PSUPL=PSUPL+1 174 ; 175 NEW PSUMAX,PSULC,PSUTMC,PSUTLC,PSUMC 176 S PSUMAX=$$VAL^PSUTL(4.3,1,8.3) 177 S PSUMAX=$S(PSUMAX="":10000,PSUMAX>10000:10000,1:PSUMAX) 178 S PSUMC=1,PSUMLC=0 179 F PSULC=1:1 S X=$G(^TMP("PSUPROM",$J,PSULC)) Q:X="" D 180 .S PSUMLC=PSUMLC+1 181 .I PSUMLC>PSUMAX S PSUMC=PSUMC+1,PSUMLC=0,PSULC=PSULC-1 Q ; + message 182 .I $L(X)<235 S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=X Q 183 .F I=235:-1:1 S Z=$E(X,I) Q:Z="^" 184 .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=$E(X,1,I) 185 .S PSUMLC=PSUMLC+1 186 .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)="*"_$E(X,I+1,999) 187 ; 188 F PSUM=1:1:PSUMC D PROV^PSUDEM5 189 D CONF 190 Q 191 CONF ;Construct globals for confirmation message 192 ; 193 ; Count Lines sent 194 S PSUTLC=0 195 F PSUM=1:1:PSUMC S X=$O(^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUM,""),-1),PSUTLC=PSUTLC+X 196 ; 197 D INST^PSUDEM1 198 N PSUDIVIS 199 S PSUDIVIS=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1) 200 S PSUSUB="PSU_"_PSUJOB 201 S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,10,"M")=PSUMC 202 S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,10,"L")=PSUTLC 203 Q 1 PSUDEM4 ;BIR/DAM - Provider Extract ; 7/21/06 2:27pm 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**8**;MARCH, 2005 3 ; 4 ;DBIA'S 5 ; Reference to file 200 supported by DBIA 10060 6 ; Reference to file 7 supported by DBIA 2495 7 ; Reference to file 49 supported by DBIA 432 8 ; Reference to file 8932.1 supported by DBIA 2091 9 ; Reference to file 4.2 supported by DBIA 2496 10 ; 11 EN ;Entry point for gathering all provider information from IV, UD, Rx, 12 ;and PD modules. 13 ; 14 N PSUREC 15 S ^XTMP("PSU_"_PSUJOB,"PSUFLAG")="" 16 ; 17 D PULL^PSUCP 18 F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))="" 19 ; 20 I '$D(PSUMOD(7)) D EN^PSUDEM1 21 I '$D(PSUMOD(1)) D EN^PSUV0 22 I '$D(PSUMOD(2)) D EN^PSUUD0 23 I '$D(PSUMOD(4)) D 24 .S ^XTMP("PSU_"_PSUJOB,"PSUOPFLG")="" ;Set flag 25 .D EN^PSUOP0 26 M ^XTMP("PSU_"_PSUJOB,"PSUPROM")=^XTMP("PSU_"_PSUJOB,"PSUPROV") 27 ; 28 D XMD 29 D EN^PSUSUM1 ;compose provider summary report and mail it. 30 K ^XTMP("PSU_"_PSUJOB,"PSUFLAG") 31 Q 32 ; 33 PDSSN ;EN Called from PSUDEM1 34 ;Find provider SSN and IEN present in the patient demographics 35 ;extract. Note that this is the primary care provider. 36 ; 37 S PSUT=0 38 F S PSUT=$O(^XTMP("PSU_"_PSUJOB,"PSUDM",PSUT)) Q:'PSUT D 39 .N PSUIEN,PSUSSN1 40 .S PSUIEN=$P($G(^XTMP("PSU_"_PSUJOB,"PSUDM",PSUT)),U,15) I 'PSUIEN S PSUIEN="UNK" 41 .D FAC 42 .D PNAM 43 .S PSUSSN1=$P($G(^XTMP("PSU_"_PSUJOB,"PSUDM",PSUT)),U,14) I 'PSUSSN1 S PSUSSN1="" 44 .S PSUREC=PSUSSN1 D REC^PSUDEM2 45 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,3)=PSUREC ;Dem Prov SSN 46 .S PSUREC=PSUIEN D REC^PSUDEM2 47 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,4)=PSUREC D ;Dem Prov ICN 48 ..I PSUREC="UNK" K ^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN) 49 Q 50 ; 51 UDSSN ;EN Called from PROV^PSUUD1. Find provider SSN and IEN in the unit 52 ;dose extract 53 ; 54 S PSUIEN=0,PSUVSSN1=0 55 F S PSUVSSN1=$O(^XTMP("PSU_"_PSUJOB,"PSUPDR",PSUVSSN1)) Q:PSUVSSN1="" D 56 .F S PSUIEN=$O(^XTMP("PSU_"_PSUJOB,"PSUPDR",PSUVSSN1,PSUIEN)) Q:PSUIEN="" D 57 ..D FAC 58 ..S PSUREC=PSUVSSN1 D REC^PSUDEM1 D 59 ...I PSUREC=999999999 S PSUREC="" 60 ...S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,3)=PSUREC ;UD Prov SSN 61 ..S PSUREC=PSUIEN D REC^PSUDEM2 62 ..S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,4)=PSUREC ;UD Prov IEN 63 ..D PNAM 64 Q 65 ; 66 IVSSN ;EN Called from PSUIV1. Gives Provider within date range of extract 67 ; 68 D UDSSN 69 Q 70 ; 71 OPSSN ;EN Called from PSUOP0. Gives prescription Provider 72 ; 73 D UDSSN 74 Q 75 FAC ;Find provider station number. Places that info in each record. 76 ; 77 ;D INST^PSUDEM1 78 S $P(^TMP("PSUPROV",$J),U,2)=PSUSNDR 79 M ^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN)=^TMP("PSUPROV",$J) 80 Q 81 ; 82 PNAM ;Find the provider's name. 83 ; 84 N PSUCLP,PSUSS,PSUSP 85 ; 86 ;Find provider name 87 S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,9)=$$GET1^DIQ(200,PSUIEN,.01,"I") 88 ; 89 S PSUCLP=$$GET1^DIQ(200,PSUIEN,53.5,"I") D CLASS ;Provider pointer 90 S PSUSS=$$GET1^DIQ(200,PSUIEN,29,"I") D SS ;Service Sctn ptr 91 ; 92 S PSUD1=999 93 S PSUD1=$O(^VA(200,PSUIEN,"USC1",PSUD1),-1) ;Find last subscript 94 I PSUD1'="" D 95 .S PSUSP=$$GET1^DIQ(200.05,PSUD1_","_PSUIEN_",",.01,"I") ;Specialty 96 .D SPEC 97 I PSUD1="" D 98 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)="" 99 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)="" 100 Q 101 ; 102 CLASS ;Find provider class 103 ; 104 I '$D(PSUCLP) S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)="" 105 I PSUCLP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)="" 106 I PSUCLP'="" D 107 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)=$P($G(^DIC(7,PSUCLP,0)),U,2) ;Prov class 108 Q 109 ; 110 SS ;Find Provider Service/Section 111 ; 112 N PSUTMP 113 ; 114 I PSUSS="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,6)="" 115 I PSUSS'="" S PSUTMP=1 D 116 .S:$P($G(^DIC(49,PSUSS,0)),U)["AMBU" PSUTMP="AMB" 117 .S:$P($G(^DIC(49,PSUSS,0)),U)["ANESTH" PSUTMP="ANES" 118 .S:$P($G(^DIC(49,PSUSS,0)),U)["CARDIO" PSUTMP="CV" 119 .S:$P($G(^DIC(49,PSUSS,0)),U)["PHARM" PSUTMP="CPHAR" 120 .S:$P($G(^DIC(49,PSUSS,0)),U)["DENT" PSUTMP="DDS" 121 .S:$P($G(^DIC(49,PSUSS,0)),U)["MEDIC" PSUTMP="MED" 122 .S:$P($G(^DIC(49,PSUSS,0)),U)["INTERMED" PSUTMP="IM" 123 .S:$P($G(^DIC(49,PSUSS,0)),U)["NUCLEAR" PSUTMP="NUM" 124 .S:$P($G(^DIC(49,PSUSS,0)),U)["NURSING" PSUTMP="RN" 125 .S:$P($G(^DIC(49,PSUSS,0)),U)["ORTHOPED" PSUTMP="ORTHO" 126 .S:$P($G(^DIC(49,PSUSS,0)),U)["PSYCHIA" PSUTMP="PSY" 127 .S:$P($G(^DIC(49,PSUSS,0)),U)["MENTAL" PSUTMP="PSY" 128 .S:$P($G(^DIC(49,PSUSS,0)),U)["PRIMARY" PSUTMP="AMB" 129 .S:$P($G(^DIC(49,PSUSS,0)),U)["CBOC" PSUTMP="AMB" 130 .S:$P($G(^DIC(49,PSUSS,0)),U)["OPHTH" PSUTMP="OPH" 131 .S:$P($G(^DIC(49,PSUSS,0)),U)["PULM" PSUTMP="PUL" 132 .S:$P($G(^DIC(49,PSUSS,0)),U)["RADIOL" PSUTMP="RAD" 133 .S:$P($G(^DIC(49,PSUSS,0)),U)["SURG" PSUTMP="SUR" 134 .S:$P($G(^DIC(49,PSUSS,0)),U)["UROLOG" PSUTMP="U" 135 .S:$P($G(^DIC(49,PSUSS,0)),U)["NEUROL" PSUTMP="NEUR" 136 .S PSUREC=$G(PSUTMP) D REC^PSUDEM2 137 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,6)=$G(PSUREC) ;Prov Serv/Sec 138 Q 139 ; 140 SPEC ;Find provider specialty and sub-specialty 141 ; 142 I PSUSP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)="" 143 I PSUSP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)="" 144 I PSUSP'="" D 145 .S PSUREC=$P($G(^USC(8932.1,PSUSP,0)),U,2) D REC^PSUDEM2 146 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)=PSUREC D ;Speclty 147 ..I $P(^USC(8932.1,PSUSP,0),U,2)="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)="" 148 .S PSUREC=$P($G(^USC(8932.1,PSUSP,0)),U,3) D REC^PSUDEM2 149 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)=PSUREC D ;Subspecl 150 ..I $P(^USC(8932.1,PSUSP,0),U,3)="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)="" 151 ; 152 Q 153 ; 154 XMD ;Format mailman message and send. 155 ; 156 S PSUAA=0 157 F S PSUAA=$O(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAA)) Q:PSUAA="" D 158 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAA),U,9)="" ;Remove provider name 159 ; 160 ;Remove space in piece 8 161 S PSUAB=0 162 F S PSUAB=$O(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAB)) Q:PSUAB="" D 163 .I $P(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAB),U,8)=" " D 164 ..S $P(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAB),U,8)="" 165 ; 166 S PSUAC=0,PSUPL=1 167 F S PSUAC=$O(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAC)) Q:PSUAC="" D 168 .M ^TMP("PSUPROM",$J,PSUPL)=^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAC) ;numerical order 169 .S PSUPL=PSUPL+1 170 ; 171 NEW PSUMAX,PSULC,PSUTMC,PSUTLC,PSUMC 172 S PSUMAX=$$VAL^PSUTL(4.3,1,8.3) 173 S PSUMAX=$S(PSUMAX="":10000,PSUMAX>10000:10000,1:PSUMAX) 174 S PSUMC=1,PSUMLC=0 175 F PSULC=1:1 S X=$G(^TMP("PSUPROM",$J,PSULC)) Q:X="" D 176 .S PSUMLC=PSUMLC+1 177 .I PSUMLC>PSUMAX S PSUMC=PSUMC+1,PSUMLC=0,PSULC=PSULC-1 Q ; + message 178 .I $L(X)<235 S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=X Q 179 .F I=235:-1:1 S Z=$E(X,I) Q:Z="^" 180 .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=$E(X,1,I) 181 .S PSUMLC=PSUMLC+1 182 .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)="*"_$E(X,I+1,999) 183 ; 184 F PSUM=1:1:PSUMC D PROV^PSUDEM5 185 D CONF 186 Q 187 CONF ;Construct globals for confirmation message 188 ; 189 ; Count Lines sent 190 S PSUTLC=0 191 F PSUM=1:1:PSUMC S X=$O(^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUM,""),-1),PSUTLC=PSUTLC+X 192 ; 193 D INST^PSUDEM1 194 N PSUDIVIS 195 S PSUDIVIS=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1) 196 S PSUSUB="PSU_"_PSUJOB 197 S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,10,"M")=PSUMC 198 S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,10,"L")=PSUTLC 199 Q
Note:
See TracChangeset
for help on using the changeset viewer.
