Changeset 623 for WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (16 years ago)
- Location:
- WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU
- Files:
-
- 10 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUCP.m
r613 r623 1 PSUCP ;BIR/TJH,PDW - PBM CONTROL POINT ; 06/08/07 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19 3 ; Reference to File #4 supported by DBIA 10090 4 ; Reference to File #4.3 supported by DBIA 10091 5 ; Reference to File #40.8 supported by DBIA 2438 6 ; Reference to File #59.7 supported by DBIA 2854 7 ; move CLEANUP^PSUHL from PSURT1, delete calls to PSUCP3 (PSU*4*12) 8 MANUAL ; entry point for manual option 9 S PSUALERT=0 D MANUAL^PSUALERT 10 I PSUALERT K PSUALERT Q 11 K PSUALERT 12 S PSUFQ=1 13 I $D(^XTMP("PSUJFLG")) D Q:Y=0 Q:Y="^" 14 .W !!,"NOTE: A PREVIOUS JOB HAS NOT COMPLETED DUE TO AN ERROR" 15 .W !!,"PLEASE ALERT YOUR IRM." 16 .W !!,"RESPOND 'YES' TO CONTINUE, OR 'NO' TO EXIT" 17 .S DIR(0)="Y",DIR("B")="NO" 18 .S DIR("A")="Do you wish to continue" 19 .D ^DIR 20 D CLEANUP^PSUHL 21 S PSUJOB=$J_"_"_$P($H,",",2) 22 S ^XTMP("PSUMANL")="" 23 D EN^PSUCP1 ; prompt for report choices 24 I PSUERR G EXIT 25 D XMY^PSUTL1 ; Setup for mail groups according to choices 26 S ^XTMP("PSUJFLG")="",PSUAUTO=0,^XTMP("PSU_"_PSUJOB,"PSUJOB")=PSUJOB 27 D PUT 28 S PSUTITLE="PSU PBM MANUAL",PSURC="RUN^PSUCP" 29 S PSURP=$S('$L(PSUIOP):"",1:"PRINT^PSUCP") 30 S PSURX="EXIT^PSUCP",PSUNS="PS" 31 S ^XTMP("PSU","RUNNING")=$G(ZTSK) 32 K PSUALERT,XAQ,SQAFLG,SQAID,XQAMSG,XQMSG,ZTSK 33 D ^PSUDBQUE 34 MANUALQ Q 35 ; 36 AUTO ; set variables for Auto-report option and task to background 37 S PSUALERT=0 D AUTO^PSUALERT 38 I PSUALERT K PSUALERT Q 39 I $D(^XTMP("PSU","RUNNING")) D Q 40 .S XQA(DUZ)="",XQA("G.PSU PBM")="",XQMSG="An ERROR has occurred. Please contact IRM for assistance." 41 .S XQAID="PSU",XQAFLG="D" D SETUP^XQALERT 42 D CLEANUP^PSUHL 43 S PSUJOB=$J_"_"_$P($H,",",2) 44 S ^XTMP("PSU_"_PSUJOB,"PSUFLAG1")="" ;flag for mail patient summary reports 45 S ^XTMP("PSU_"_PSUJOB,"PSUPSUMFLAG")=1 ;Set 'auto' flag 46 S ^XTMP("PSUJFLG")="" ;FLAG to avoid concurrent jobs running 47 D ; schedule job completion check 48 .S PSURC="AUTO^PSUCP2",PSUTITLE="PSU PBM JOB CHECK",PSUFQ=1 49 .S (PSURP,PSURX,PSUIOP)="" 50 .D NOW^%DTC S X1=%,X2=6 D C^%DTC S PSUDTH=X ; LIVE MODE, wait 6 days (72 hours) 51 .D ^PSUDBQUE 52 .S ^XTMP("PSU","RUNNING")=$G(ZTSK) 53 D NOW^%DTC S PSUMON=$S('$D(DT):X,1:DT),PSUMON=$E(PSUMON,1,5)-1 ; get previous month 54 I $E(PSUMON,4,5)="00" S PSUMON=($E(PSUMON,1,3)-1)_"12" ; set to Dec. of previous year if this month is Jan. 55 S ^XTMP("PSU_"_PSUJOB,"PSUMONTH")=PSUMON,PSUSDT=PSUMON_"01" 56 S PSULY=$$LEAPYR(PSUMON),X=U_$E(PSUMON,4,5)_U 57 S PSUEDT=PSUMON_$S(X["02":$S(PSULY:"29",1:"28"),"^04^06^09^11^"[X:"30",1:"31") 58 S PSUDUZ=$S(DUZ=0:.5,1:DUZ),PSUMASF=1,PSUSMRY=0,PSUPBMG=1 59 S ^XTMP("PSU_"_PSUJOB,"PSUPDFLAG")=1 ;Flag-detailed PD won't go to user auto extract 60 S X=$$VALI^PSUTL(4.3,1,217),PSUSNDR=+$$VAL^PSUTL(4,X,99) 61 S PSUOPTS="1,2,3,4,5,6,7,8,9,10,11,12,13",PSUAUTO=1,PSUIOP="" D 62 .S ^XTMP("PSU_"_PSUJOB,"CBAMIS")="" 63 S ^XTMP("PSU_"_PSUJOB,"PSUJOB")=PSUJOB 64 D PUT 65 S PSUTITLE="PSU PBM AUTO",PSURC="RUN^PSUCP",PSURX="EXIT^PSUCP",PSURP="",PSUNS="PS",PSUFQ=1 66 D NOW^%DTC S PSUDTH=% 67 D ^PSUDBQUE 68 K PSUALERT,XQA,XQAID,XQAFLG,XQA,ZTSK 69 AUTOQ Q ; exit from AUTO 70 ; 71 RUN ; run each selected module 72 L ^XTMP("PSU","RUNNING"):1 I '$T Q 73 D PULL,OPTS 74 K PSUMOD,PSUFDA 75 I PSUAUTO S PSUFDA(59.7,"1,",90)="@" D FILE^DIE("","PSUFDA","") 76 F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))="" 77 S PSUOPTN="" 78 F S PSUOPTN=$O(PSUMOD(PSUOPTN)) Q:PSUOPTN="" D 79 .K PSUMSGT 80 .D PULL 81 .I PSUAUTO S PSUPBMG=1 82 .D XMY^PSUTL1 83 .S PSURTN=PSUA(PSUOPTN,"R") 84 .D NOW^%DTC 85 .S ^XTMP("PSU_"_PSUJOB,"STATUS",PSUOPTN,"START")=% 86 .D @PSURTN,PULL,NOW^%DTC 87 .S ^XTMP("PSU_"_PSUJOB,"STATUS",PSUOPTN,"STOP")=% 88 D DT^DILF("E",PSUSDT,.EXTD) 89 S PSURP("START")=EXTD(0) 90 D DT^DILF("E",PSUEDT,.EXTD) 91 S PSURP("END")=EXTD(0),PSUSUB="PSU_"_PSUJOB 92 D MMNOMAP^PSUCP2 ; MM send regarding PBM locations not mapped 93 D TIMING ; send a report of how long each module took to complete 94 I PSUMASF!PSUPBMG D CONFIRM ;Confirmation message sent only if data went to Master File 95 I PSUAUTO D 96 .D NOW^%DTC 97 .S PSUFDA(59.7,"1,",90)=% K %,%H,%I,X 98 .D FILE^DIE("","PSUFDA","") ; file the completion date in 59.7,90;1 99 L 100 ; 101 Q 102 PRINT ; print hard copy if requested 103 Q:'$L(PSUIOP) ; no printer selected, stop right here. 104 D PULL,OPTS 105 K PSUMOD 106 F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))="" 107 S PSUOPTN="" 108 F S PSUOPTN=$O(PSUMOD(PSUOPTN)) Q:PSUOPTN="" D 109 .D PULL 110 .S PSURTN=PSUA(PSUOPTN,"P") 111 .D @PSURTN 112 L 113 K ^XTMP("PSU","RUNNING") 114 PRINTQ Q 115 EXIT ; exit point 116 K ^XTMP("PSU","RUNNING") 117 K ^XTMP("PSUJFLG") ;Remove flag to prevent concurrent jobs 118 Q 119 PUT ; put variables in ^XTMP so modules can retrieve them 120 S PSUVARS="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,PSUIOP,PSUSNDR,PSUOPTS,PSUAUTO" 121 S PSUVSTR="" 122 F I=1:1:$L(PSUVARS,",") S $P(PSUVSTR,U,I)=@$P(PSUVARS,",",I) 123 S X1=DT,X2=6 D C^%DTC 124 S ^XTMP("PSU_"_PSUJOB,0)=X_U_DT_U_"Control data for PSU PBM individual modules" 125 S ^XTMP("PSU_"_PSUJOB,1)=PSUVSTR 126 K PSUVARS,PSUVSTR,X,X1 127 PUTQ Q 128 PULL ; pull variables from ^XTMP 129 ; PSUJOB must exist and must be the job number used to store the data desired for this session. 130 N I 131 S PSUVARS="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,PSUIOP,PSUSNDR,PSUOPTS,PSUAUTO" 132 F I=1:1:$L(PSUVARS,",") S @$P(PSUVARS,",",I)=$P($G(^XTMP("PSU_"_PSUJOB,1)),U,I) 133 PULLQ Q 134 ; 135 OPTS ; set option array 136 S PSUA(1,"M")="IVs",PSUA(1,"R")="EN^PSUV0",PSUA(1,"P")="PRINT^PSUV0",PSUA(1,"C")="IV" 137 S PSUA(2,"M")="Unit Dose",PSUA(2,"R")="EN^PSUUD0",PSUA(2,"P")="PRINT^PSUUD0",PSUA(2,"C")="UD" 138 S PSUA(3,"M")="AR/WS",PSUA(3,"R")="EN^PSUAR0",PSUA(3,"P")="PRINT^PSUAR0",PSUA(3,"C")="AR" 139 S PSUA(4,"M")="Prescription",PSUA(4,"R")="EN^PSUOP0",PSUA(4,"P")="PRINT^PSUOP0",PSUA(4,"C")="OP" 140 S PSUA(5,"M")="Procurement",PSUA(5,"R")="EN^PSUPR0",PSUA(5,"P")="PRINT^PSUPR0",PSUA(5,"C")="PR" 141 S PSUA(6,"M")="Controlled Substances",PSUA(6,"R")="EN^PSUCS0",PSUA(6,"P")="PRINT^PSUCS0",PSUA(6,"C")="CS" 142 S PSUA(7,"M")="Patient Demographics",PSUA(7,"R")="EN^PSUDEM1",PSUA(7,"P")="PRINT^PSUDEM0",PSUA(7,"C")="PD" 143 S PSUA(8,"M")="Outpatient Visits",PSUA(8,"R")="EN^PSUDEM2",PSUA(8,"P")="OPV^PSUDEM0",PSUA(8,"C")="OV" 144 S PSUA(9,"M")="Inpatient PTF Records",PSUA(9,"R")="EN^PSUDEM7",PSUA(9,"P")="PTF^PSUDEM0",PSUA(9,"C")="PTF" 145 S PSUA(10,"M")="Provider Data",PSUA(10,"R")="EN^PSUDEM4",PSUA(10,"P")="PRO^PSUDEM0",PSUA(10,"C")="PRO" 146 S PSUA(11,"M")="Allergies/Adverse Events",PSUA(11,"R")="EN^PSUAA1",PSUA(11,"P")="PRINT^PSUAA1",PSUA(11,"C")="AA" 147 S PSUA(12,"M")="Vitals/Immunizations Information",PSUA(12,"R")="EN^PSUVIT1",PSUA(12,"P")="EN^PSUVIT0",PSUA(12,"C")="VI" 148 S PSUA(13,"M")="Laboratory Results",PSUA(13,"R")="EN^PSULR0",PSUA(13,"P")="PRINT^PSULR0",PSUA(13,"C")="LR" 149 S PSUA("A")="" 150 OPTSQ Q 151 ; 152 CONFIRM ;Send confirmation by Division(s) 153 K PSUCONF 154 S PSUDIV=0,$P(PSUDASH,"-",81)="" 155 D OPTS 156 S PSUCONF(1)="The chart below shows the package(s) whose dispensing statistics were extracted" 157 S PSUCONF(2)="by the PBM "_$S($G(PSUAUTO):"Automatic",$G(PSURXMT):"RETRANSMISSION",1:"Manual")_" Pharmacy Statistics option." 158 ; S PSUCONF(2)="by the PBM "_$S(PSUAUTO:"Automatic",1:"Manual")_" Pharmacy Statistics option." 159 S PSUCONF(3)=" " 160 S PSUCONF(4)="PACKAGE"_$J("# Line items",35)_$J("# MailMan msgs",19) 161 S PSUCONF(5)=$E(PSUDASH,1,79) 162 F S PSUDIV=$O(^XTMP(PSUSUB,"CONFIRM",PSUDIV)) Q:PSUDIV'?1N.E D 163 .K ^XTMP(PSUSUB,"XMD") 164 .M ^XTMP(PSUSUB,"XMD")=PSUCONF 165 .S PSUOPT=0,PSULCT=5 166 .F S PSUOPT=$O(^XTMP(PSUSUB,"CONFIRM",PSUDIV,PSUOPT)) Q:PSUOPT'?1.N D 167 ..S PSULCT=PSULCT+1 168 ..S PSUPKG=PSUA(PSUOPT,"M") 169 ..S PSULIN=^XTMP(PSUSUB,"CONFIRM",PSUDIV,PSUOPT,"L") 170 ..S PSUMSG=^XTMP(PSUSUB,"CONFIRM",PSUDIV,PSUOPT,"M") 171 ..S ^XTMP(PSUSUB,"XMD",PSULCT)=PSUPKG_$J(PSULIN,37-$L(PSUPKG))_$J(PSUMSG,12) 172 ..Q:PSUPKG'="Prescription" ;* 173 .. ; process Prescription MultiDose 174 ..S PSULCT=PSULCT+1 175 ..S PSUPKG="Prescription MultiDose" 176 ..S PSULIN=+$G(^XTMP(PSUSUB,"CONFIRMD",PSUDIV,PSUOPT,"L")) 177 ..S PSUMSG=+$G(^XTMP(PSUSUB,"CONFIRMD",PSUDIV,PSUOPT,"M")) 178 ..S ^XTMP(PSUSUB,"XMD",PSULCT)=PSUPKG_$J(PSULIN,37-$L(PSUPKG))_$J(PSUMSG,12) ;* 179 .S PSUSUBJ="PBM Stats for " 180 .I $G(PSUMASF)!$G(PSUDUZ)!$G(PSUPBMG) D XMD 181 CONFIRMQ Q 182 ; 183 XMD ;Email 184 ; 185 S XMDUZ=DUZ 186 D XMY^PSUTL1 187 M XMY=PSUXMYS1 188 I $G(PSUMASF)!$G(PSUPBMG) M XMY=PSUXMYH 189 S X=PSUDIV,DIC=40.8,DIC(0)="XM" D ^DIC 190 S X=+Y S PSUDIVNM=$$VAL^PSUTL(40.8,X,.01) 191 S XMSUB=PSUSUBJ_PSURP("START")_" to "_PSURP("END")_" from "_PSUDIV_" "_PSUDIVNM 192 S XMTEXT="^XTMP(PSUSUB,""XMD""," 193 S XMCHAN=1 194 D ^XMD 195 XMDQ Q 196 ; 197 TIMING ; Timing report 198 K ^XTMP(PSUSUB,"XMD") 199 S $P(PSUSPACE," ",41)="" 200 S PSUX=0,PSULCT=0 201 F S PSUX=$O(^XTMP(PSUSUB,"STATUS",PSUX)) Q:PSUX="" D 202 .S (X,Y)=^XTMP(PSUSUB,"STATUS",PSUX,"START") X ^DD("DD") D 203 ..I $E(Y,17)=":" S PSUT1=$E(Y,1,16) 204 ..I $E(Y,17)'=":" S PSUT1=$E(Y,1,17) 205 .S (X1,Y)=^XTMP(PSUSUB,"STATUS",PSUX,"STOP") X ^DD("DD") D 206 ..I $E(Y,17)=":" S PSUT2=$E(Y,1,16) 207 ..I $E(Y,17)'=":" S PSUT2=$E(Y,1,17) 208 .S Y=$E(X1_"000",9,10)-$E(X_"000",9,10)*60+$E(X1_"00000",11,12)-$E(X_"00000",11,12),X2=X,X=$P(X,".",1)'=$P(X1,".",1) 209 .D ^%DTC:X S X=X*1440+Y 210 .S PSULCT=PSULCT+1 211 .S PSUREC=$E(PSUA(PSUX,"M")_PSUSPACE,1,20)_$J(PSUT1,20)_$J(PSUT2,20)_$J(X\60,4)_" hrs,"_$J(X#60,3)_" min" 212 .S ^XTMP(PSUSUB,"XMD",PSULCT)=PSUREC 213 S PSULCT=PSULCT+1 214 S $P(^XTMP(PSUSUB,"XMD",PSULCT),"-",80)="" S PSULCT=PSULCT+1 215 S ^XTMP(PSUSUB,"XMD",PSULCT)="" S PSULCT=PSULCT+1 216 S ^XTMP(PSUSUB,"XMD",PSULCT)="**NOTE: Timing for the Provider Data extract is not recorded when" S PSULCT=PSULCT+1 217 S ^XTMP(PSUSUB,"XMD",PSULCT)=" the IV, Unit Dose, Prescription, and Patient Demographics extracts" S PSULCT=PSULCT+1 218 S ^XTMP(PSUSUB,"XMD",PSULCT)=" are run concurrently." 219 S PSUDIV=PSUSNDR 220 S PSUSUBJ="PBM TIMING for report " 221 D XMD 222 TIMINGQ Q 223 ; 224 LEAPYR(FMYR) ; Check to see if year is a leap year: 1=leap year, 0=not leap year 225 N YYYY 226 S YYYY=1700+$E(FMYR,1,3) 227 Q (((YYYY#4=0)&(YYYY#100'=0))!((YYYY#100=0)&(YYYY#400=0))) 1 PSUCP ;BIR/TJH,PDW - PBM CONTROL POINT ;25 AUG 1998 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005 3 ; Reference to File #4 supported by DBIA 10090 4 ; Reference to File #4.3 supported by DBIA 10091 5 ; Reference to File #40.8 supported by DBIA 2438 6 ; Reference to File #59.7 supported by DBIA 2854 7 MANUAL ; entry point for manual option 8 S PSUALERT=0 D MANUAL^PSUALERT 9 I PSUALERT K PSUALERT Q 10 K PSUALERT 11 S PSUFQ=1 12 I $D(^XTMP("PSUJFLG")) D Q:Y=0 Q:Y="^" 13 .W !!,"NOTE: A PREVIOUS JOB HAS NOT COMPLETED DUE TO AN ERROR" 14 .W !!,"PLEASE ALERT YOUR IRM." 15 .W !!,"RESPOND 'YES' TO CONTINUE, OR 'NO' TO EXIT" 16 .S DIR(0)="Y",DIR("B")="NO" 17 .S DIR("A")="Do you wish to continue" 18 .D ^DIR 19 D ^PSUCP3 20 S PSUJOB=$J_"_"_$P($H,",",2) 21 S ^XTMP("PSUMANL")="" 22 D EN^PSUCP1 ; prompt for report choices 23 I PSUERR G EXIT 24 D XMY^PSUTL1 ; Setup for mail groups according to choices 25 S ^XTMP("PSUJFLG")="",PSUAUTO=0,^XTMP("PSU_"_PSUJOB,"PSUJOB")=PSUJOB 26 D PUT 27 S PSUTITLE="PSU PBM MANUAL",PSURC="RUN^PSUCP" 28 S PSURP=$S('$L(PSUIOP):"",1:"PRINT^PSUCP") 29 S PSURX="EXIT^PSUCP",PSUNS="PS" 30 S ^XTMP("PSU","RUNNING")=$G(ZTSK) 31 K PSUALERT,XAQ,SQAFLG,SQAID,XQAMSG,XQMSG,ZTSK 32 D ^PSUDBQUE 33 MANUALQ Q 34 ; 35 AUTO ; set variables for Auto-report option and task to background 36 S PSUALERT=0 D AUTO^PSUALERT 37 I PSUALERT K PSUALERT Q 38 I $G(^XTMP("PSU","RUNNING")) D Q 39 .S XQA(DUZ)="",XQA("G.PSU PBM")="",XQMSG="An ERROR has occurred. Please contact IRM for assistance." 40 .S XQAID="PSU",XQAFLG="D" D SETUP^XQALERT 41 D ^PSUCP3 ;Clear trash globals 42 S PSUJOB=$J_"_"_$P($H,",",2) 43 S ^XTMP("PSU_"_PSUJOB,"PSUFLAG1")="" ;flag for mail patient summary reports 44 S ^XTMP("PSU_"_PSUJOB,"PSUPSUMFLAG")=1 ;Set 'auto' flag 45 S ^XTMP("PSUJFLG")="" ;FLAG to avoid concurrent jobs running 46 D ; schedule job completion check 47 .S PSURC="AUTO^PSUCP2",PSUTITLE="PSU PBM JOB CHECK",PSUFQ=1 48 .S (PSURP,PSURX,PSUIOP)="" 49 .D NOW^%DTC S X1=%,X2=6 D C^%DTC S PSUDTH=X ; LIVE MODE, wait 6 days (72 hours) 50 .D ^PSUDBQUE 51 .S ^XTMP("PSU","RUNNING")=$G(ZTSK) 52 D NOW^%DTC S PSUMON=$S('$D(DT):X,1:DT),PSUMON=$E(PSUMON,1,5)-1 ; get previous month 53 I $E(PSUMON,4,5)="00" S PSUMON=($E(PSUMON,1,3)-1)_"12" ; set to Dec. of previous year if this month is Jan. 54 S ^XTMP("PSU_"_PSUJOB,"PSUMONTH")=PSUMON,PSUSDT=PSUMON_"01" 55 S PSULY=$$LEAPYR(PSUMON),X=U_$E(PSUMON,4,5)_U 56 S PSUEDT=PSUMON_$S(X["02":$S(PSULY:"29",1:"28"),"^04^06^09^11^"[X:"30",1:"31") 57 S PSUDUZ=$S(DUZ=0:.5,1:DUZ),PSUMASF=1,PSUSMRY=0,PSUPBMG=1 58 S ^XTMP("PSU_"_PSUJOB,"PSUPDFLAG")=1 ;Flag-detailed PD won't go to user auto extract 59 S X=$$VALI^PSUTL(4.3,1,217),PSUSNDR=+$$VAL^PSUTL(4,X,99) 60 S PSUOPTS="1,2,3,4,5,6,7,8,9,10,11,12,13",PSUAUTO=1,PSUIOP="" D 61 .S ^XTMP("PSU_"_PSUJOB,"CBAMIS")="" 62 S ^XTMP("PSU_"_PSUJOB,"PSUJOB")=PSUJOB 63 D PUT 64 S PSUTITLE="PSU PBM AUTO",PSURC="RUN^PSUCP",PSURX="EXIT^PSUCP",PSURP="",PSUNS="PS",PSUFQ=1 65 D NOW^%DTC S PSUDTH=% 66 D ^PSUDBQUE 67 K PSUALERT,XQA,XQAID,XQAFLG,XQA,ZTSK 68 AUTOQ D EXIT Q ; exit from AUTO 69 ; 70 RUN ; run each selected module 71 L ^XTMP("PSU","RUNNING"):1 I '$T Q 72 D PULL,OPTS 73 K PSUMOD,PSUFDA 74 I PSUAUTO S PSUFDA(59.7,"1,",90)="@" D FILE^DIE("","PSUFDA","") 75 F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))="" 76 S PSUOPTN="" 77 F S PSUOPTN=$O(PSUMOD(PSUOPTN)) Q:PSUOPTN="" D 78 .K PSUMSGT 79 .D PULL 80 .I PSUAUTO S PSUPBMG=1 81 .D XMY^PSUTL1 82 .S PSURTN=PSUA(PSUOPTN,"R") 83 .D NOW^%DTC 84 .S ^XTMP("PSU_"_PSUJOB,"STATUS",PSUOPTN,"START")=% 85 .D @PSURTN,PULL,NOW^%DTC 86 .S ^XTMP("PSU_"_PSUJOB,"STATUS",PSUOPTN,"STOP")=% 87 D DT^DILF("E",PSUSDT,.EXTD) 88 S PSURP("START")=EXTD(0) 89 D DT^DILF("E",PSUEDT,.EXTD) 90 S PSURP("END")=EXTD(0),PSUSUB="PSU_"_PSUJOB 91 D MMNOMAP^PSUCP2 ; MM send regarding PBM locations not mapped 92 D TIMING ; send a report of how long each module took to complete 93 I PSUMASF!PSUPBMG D CONFIRM ;Confirmation message sent only if data went to Master File 94 I PSUAUTO D 95 .D NOW^%DTC 96 .S PSUFDA(59.7,"1,",90)=% K %,%H,%I,X 97 .D FILE^DIE("","PSUFDA","") ; file the completion date in 59.7,90;1 98 L 99 ; 100 Q 101 PRINT ; print hard copy if requested 102 Q:'$L(PSUIOP) ; no printer selected, stop right here. 103 D PULL,OPTS 104 K PSUMOD 105 F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))="" 106 S PSUOPTN="" 107 F S PSUOPTN=$O(PSUMOD(PSUOPTN)) Q:PSUOPTN="" D 108 .D PULL 109 .S PSURTN=PSUA(PSUOPTN,"P") 110 .D @PSURTN 111 L 112 K ^XTMP("PSU","RUNNING") 113 PRINTQ Q 114 EXIT ; exit point 115 K ^XTMP("PSU","RUNNING") 116 K ^XTMP("PSUJFLG") ;Remove flag to prevent concurrent jobs 117 Q 118 PUT ; put variables in ^XTMP so modules can retrieve them 119 S PSUVARS="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,PSUIOP,PSUSNDR,PSUOPTS,PSUAUTO" 120 S PSUVSTR="" 121 F I=1:1:$L(PSUVARS,",") S $P(PSUVSTR,U,I)=@$P(PSUVARS,",",I) 122 S X1=DT,X2=6 D C^%DTC 123 S ^XTMP("PSU_"_PSUJOB,0)=X_U_DT_U_"Control data for PSU PBM individual modules" 124 S ^XTMP("PSU_"_PSUJOB,1)=PSUVSTR 125 K PSUVARS,PSUVSTR,X,X1 126 PUTQ Q 127 PULL ; pull variables from ^XTMP 128 ; PSUJOB must exist and must be the job number used to store the data desired for this session. 129 N I 130 S PSUVARS="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,PSUIOP,PSUSNDR,PSUOPTS,PSUAUTO" 131 F I=1:1:$L(PSUVARS,",") S @$P(PSUVARS,",",I)=$P($G(^XTMP("PSU_"_PSUJOB,1)),U,I) 132 PULLQ Q 133 ; 134 OPTS ; set option array 135 S PSUA(1,"M")="IVs",PSUA(1,"R")="EN^PSUV0",PSUA(1,"P")="PRINT^PSUV0",PSUA(1,"C")="IV" 136 S PSUA(2,"M")="Unit Dose",PSUA(2,"R")="EN^PSUUD0",PSUA(2,"P")="PRINT^PSUUD0",PSUA(2,"C")="UD" 137 S PSUA(3,"M")="AR/WS",PSUA(3,"R")="EN^PSUAR0",PSUA(3,"P")="PRINT^PSUAR0",PSUA(3,"C")="AR" 138 S PSUA(4,"M")="Prescription",PSUA(4,"R")="EN^PSUOP0",PSUA(4,"P")="PRINT^PSUOP0",PSUA(4,"C")="OP" 139 S PSUA(5,"M")="Procurement",PSUA(5,"R")="EN^PSUPR0",PSUA(5,"P")="PRINT^PSUPR0",PSUA(5,"C")="PR" 140 S PSUA(6,"M")="Controlled Substances",PSUA(6,"R")="EN^PSUCS0",PSUA(6,"P")="PRINT^PSUCS0",PSUA(6,"C")="CS" 141 S PSUA(7,"M")="Patient Demographics",PSUA(7,"R")="EN^PSUDEM1",PSUA(7,"P")="PRINT^PSUDEM0",PSUA(7,"C")="PD" 142 S PSUA(8,"M")="Outpatient Visits",PSUA(8,"R")="EN^PSUDEM2",PSUA(8,"P")="OPV^PSUDEM0",PSUA(8,"C")="OV" 143 S PSUA(9,"M")="Inpatient PTF Records",PSUA(9,"R")="EN^PSUDEM7",PSUA(9,"P")="PTF^PSUDEM0",PSUA(9,"C")="PTF" 144 S PSUA(10,"M")="Provider Data",PSUA(10,"R")="EN^PSUDEM4",PSUA(10,"P")="PRO^PSUDEM0",PSUA(10,"C")="PRO" 145 S PSUA(11,"M")="Allergies/Adverse Events",PSUA(11,"R")="EN^PSUAA1",PSUA(11,"P")="PRINT^PSUAA1",PSUA(11,"C")="AA" 146 S PSUA(12,"M")="Vitals/Immunizations Information",PSUA(12,"R")="EN^PSUVIT1",PSUA(12,"P")="EN^PSUVIT0",PSUA(12,"C")="VI" 147 S PSUA(13,"M")="Laboratory Results",PSUA(13,"R")="EN^PSULR0",PSUA(13,"P")="PRINT^PSULR0",PSUA(13,"C")="LR" 148 S PSUA("A")="" 149 OPTSQ Q 150 ; 151 CONFIRM ;Send confirmation by Division(s) 152 K PSUCONF 153 S PSUDIV=0,$P(PSUDASH,"-",81)="" 154 D OPTS 155 S PSUCONF(1)="The chart below shows the package(s) whose dispensing statistics were extracted" 156 S PSUCONF(2)="by the PBM "_$S($G(PSUAUTO):"Automatic",$G(PSURXMT):"RETRANSMISSION",1:"Manual")_" Pharmacy Statistics option." 157 ; S PSUCONF(2)="by the PBM "_$S(PSUAUTO:"Automatic",1:"Manual")_" Pharmacy Statistics option." 158 S PSUCONF(3)=" " 159 S PSUCONF(4)="PACKAGE"_$J("# Line items",35)_$J("# MailMan msgs",19) 160 S PSUCONF(5)=$E(PSUDASH,1,79) 161 F S PSUDIV=$O(^XTMP(PSUSUB,"CONFIRM",PSUDIV)) Q:PSUDIV'?1N.E D 162 .K ^XTMP(PSUSUB,"XMD") 163 .M ^XTMP(PSUSUB,"XMD")=PSUCONF 164 .S PSUOPT=0,PSULCT=5 165 .F S PSUOPT=$O(^XTMP(PSUSUB,"CONFIRM",PSUDIV,PSUOPT)) Q:PSUOPT'?1.N D 166 ..S PSULCT=PSULCT+1 167 ..S PSUPKG=PSUA(PSUOPT,"M") 168 ..S PSULIN=^XTMP(PSUSUB,"CONFIRM",PSUDIV,PSUOPT,"L") 169 ..S PSUMSG=^XTMP(PSUSUB,"CONFIRM",PSUDIV,PSUOPT,"M") 170 ..S ^XTMP(PSUSUB,"XMD",PSULCT)=PSUPKG_$J(PSULIN,37-$L(PSUPKG))_$J(PSUMSG,12) 171 ..Q:PSUPKG'="Prescription" ;* 172 .. ; process Prescription MultiDose 173 ..S PSULCT=PSULCT+1 174 ..S PSUPKG="Prescription MultiDose" 175 ..S PSULIN=+$G(^XTMP(PSUSUB,"CONFIRMD",PSUDIV,PSUOPT,"L")) 176 ..S PSUMSG=+$G(^XTMP(PSUSUB,"CONFIRMD",PSUDIV,PSUOPT,"M")) 177 ..S ^XTMP(PSUSUB,"XMD",PSULCT)=PSUPKG_$J(PSULIN,37-$L(PSUPKG))_$J(PSUMSG,12) ;* 178 .S PSUSUBJ="PBM Stats for " 179 .I $G(PSUMASF)!$G(PSUDUZ)!$G(PSUPBMG) D XMD 180 CONFIRMQ Q 181 ; 182 XMD ;Email 183 ; 184 S XMDUZ=DUZ 185 D XMY^PSUTL1 186 M XMY=PSUXMYS1 187 I $G(PSUMASF)!$G(PSUPBMG) M XMY=PSUXMYH 188 S X=PSUDIV,DIC=40.8,DIC(0)="XM" D ^DIC 189 S X=+Y S PSUDIVNM=$$VAL^PSUTL(40.8,X,.01) 190 S XMSUB=PSUSUBJ_PSURP("START")_" to "_PSURP("END")_" from "_PSUDIV_" "_PSUDIVNM 191 S XMTEXT="^XTMP(PSUSUB,""XMD""," 192 S XMCHAN=1 193 D ^XMD 194 XMDQ Q 195 ; 196 TIMING ; Timing report 197 K ^XTMP(PSUSUB,"XMD") 198 S $P(PSUSPACE," ",41)="" 199 S PSUX=0,PSULCT=0 200 F S PSUX=$O(^XTMP(PSUSUB,"STATUS",PSUX)) Q:PSUX="" D 201 .S (X,Y)=^XTMP(PSUSUB,"STATUS",PSUX,"START") X ^DD("DD") D 202 ..I $E(Y,17)=":" S PSUT1=$E(Y,1,16) 203 ..I $E(Y,17)'=":" S PSUT1=$E(Y,1,17) 204 .S (X1,Y)=^XTMP(PSUSUB,"STATUS",PSUX,"STOP") X ^DD("DD") D 205 ..I $E(Y,17)=":" S PSUT2=$E(Y,1,16) 206 ..I $E(Y,17)'=":" S PSUT2=$E(Y,1,17) 207 .S Y=$E(X1_"000",9,10)-$E(X_"000",9,10)*60+$E(X1_"00000",11,12)-$E(X_"00000",11,12),X2=X,X=$P(X,".",1)'=$P(X1,".",1) 208 .D ^%DTC:X S X=X*1440+Y 209 .S PSULCT=PSULCT+1 210 .S PSUREC=$E(PSUA(PSUX,"M")_PSUSPACE,1,20)_$J(PSUT1,20)_$J(PSUT2,20)_$J(X\60,4)_" hrs,"_$J(X#60,3)_" min" 211 .S ^XTMP(PSUSUB,"XMD",PSULCT)=PSUREC 212 S PSULCT=PSULCT+1 213 S $P(^XTMP(PSUSUB,"XMD",PSULCT),"-",80)="" S PSULCT=PSULCT+1 214 S ^XTMP(PSUSUB,"XMD",PSULCT)="" S PSULCT=PSULCT+1 215 S ^XTMP(PSUSUB,"XMD",PSULCT)="**NOTE: Timing for the Provider Data extract is not recorded when" S PSULCT=PSULCT+1 216 S ^XTMP(PSUSUB,"XMD",PSULCT)=" the IV, Unit Dose, Prescription, and Patient Demographics extracts" S PSULCT=PSULCT+1 217 S ^XTMP(PSUSUB,"XMD",PSULCT)=" are run concurrently." 218 S PSUDIV=PSUSNDR 219 S PSUSUBJ="PBM TIMING for report " 220 D XMD 221 TIMINGQ Q 222 ; 223 LEAPYR(FMYR) ; Check to see if year is a leap year: 1=leap year, 0=not leap year 224 N YYYY 225 S YYYY=1700+$E(FMYR,1,3) 226 Q (((YYYY#4=0)&(YYYY#100'=0))!((YYYY#100=0)&(YYYY#400=0))) -
WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUDEM1.m
r613 r623 1 PSUDEM1 ;BIR/DAM - Patient Demographics Extract ; 20 DEC 2001 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19 3 ; 4 ;DBIA's 5 ; Reference to file #27.11 supported by DBIA 2462 6 ; Reference to file 2 supported by DBIA 10035, 3504 7 ; Reference to file 200 supported by DBIA 10060 8 ; Reference to file 55 supported by DBIA 3502 9 ; Reference to file 4.3 supported by DBIA 2496, 10091 10 ; Reference to file 4 supported by DBIA 10090 11 ; 12 EN ;EN Routine control module 13 ; 14 D DAT 15 I $D(^XTMP("PSUMANL")) D DEM ;Manual entry point DAM 16 I $G(^XTMP("PSU_"_PSUJOB,"PSUPSUMFLAG")) D HL7 ;Auto entry point DAM 17 I '$D(^XTMP("PSU_"_PSUJOB,"PSUFLAG")) D XMD 18 K ^XTMP("PSU_"_PSUJOB,"PSUXMD") 19 ; 20 I $G(^XTMP("PSU_"_PSUJOB,"PSUPSUMFLAG"))=1 D 21 .S PSUOPTS="1,2,3,4,5,6,7,8,9,10,11" 22 .S PSUAUTO=1 23 ; 24 ; 25 D PULL^PSUCP 26 F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))="" 27 ; 28 I $D(PSUMOD(10)) D PDSSN^PSUDEM4 ;pt. demographics provider msg 29 ; 30 K ^XTMP("PSU_"_PSUJOB,"PSUPDFLAG") 31 K ^XTMP("PSU_"_PSUJOB,"PSUDM") 32 K ^XTMP("PSU_"_PSUJOB,"PSUDMX") 33 K PSUDMDFN,PSURAC,PSURDT 34 Q 35 ; 36 HL7 ;This is the Patient Demographics extract that runs only when 37 ;the PSU PBM [AUTO] option is executed. It captures demographic 38 ;information ONLY on new or updated patient. 39 ; 40 ; *** PSU*4.0*12 - BAJ -- added QUIT if NULL 41 F S PSUSDT=$O(^PSUDEM("B",PSUSDT)) Q:PSUSDT="" Q:PSUSDT>PSUEDT D 42 . S I="" 43 . S I=$O(^PSUDEM("B",PSUSDT,I)) Q:I="" 44 . S DFN=$P(^PSUDEM(I,0),U,2) 45 . S ^XTMP("PSU"_PSUJOB,"REXMT",DFN)="" 46 K DFN 47 ; 48 S DFN="" 49 F S (DFN,PSUDMDFN)=$O(^XTMP("PSU"_PSUJOB,"REXMT",DFN)) Q:DFN="" D DEM1 50 ; 51 Q 52 ; 53 DAT ;Date Module 54 ; 55 ;Date extract was run 56 S %H=$H 57 D YMD^%DTC ;Converts $H to FileMan format 58 ; ** S $P(^TMP("PSUDM",$J),U,3)=X ;Set extract date in temp global 59 S PSURDT=X 60 ; 61 Q 62 ; 63 INST ;EN Place institution code sending report into temp global. 64 ;Institution Mailman info is in file 4.3 65 ; 66 S X=$$VALI^PSUTL(4.3,1,217),PSUSNDR=+$$VAL^PSUTL(4,X,99) 67 S $P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)=PSUSNDR 68 S PSUSIT=PSUSNDR 69 ; 70 S X=PSUSNDR,DIC=40.8,DIC(0)="X",D="C" D IX^DIC ;**1 71 S X=+Y S PSUDIVNM=$$VAL^PSUTL(40.8,X,.01) 72 S $P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,2)=PSUDIVNM 73 Q 74 ; 75 DEM ;PULL PATIENT DEMOGRAPHICS. This is run only when user selects 76 ;PSU PBM [MANUAL] option. It gather patient demographic information 77 ;for all patients in the PATIENT file #2. 78 ; 79 ;N PSUREC ;DAM TEST NEW CODE 80 N PSUREC 81 K PSUREC1,PSUREC2,PSUREC3,PSUREC4,PSUREC5,PSUREC6,PSUREC7 82 K PSUREC8,PSUREC9,PSUREC10,PSUREC11,PSUREC12,PSUREC13,PSUREC14 83 K PSUREC15,PSUDOD,VAEL,VADM 84 ; 85 S PSUNAM=0 86 F S PSUNAM=$O(^DPT("B",PSUNAM)) Q:PSUNAM="" D 87 .S PSUDMDFN=0 88 .F S (DFN,PSUDMDFN)=$O(^DPT("B",PSUNAM,PSUDMDFN)) Q:PSUDMDFN="" D DEM1 89 Q 90 ; 91 DEM1 ; 92 K PSUREC,PSUREC1,PSUREC2,PSUREC3,PSUREC4,PSUREC5,PSUREC6,PSUREC7 93 K PSUREC8,PSUREC9,PSUREC10,PSUREC11,PSUREC12,PSUREC13,PSUREC14 94 K PSUREC15,PSUDOD,VAEL,VADM 95 S PSUDOD=$P($G(^DPT(PSUDMDFN,.35)),U,1) I PSUDOD,PSUDOD<2980701 Q 96 Q:'$D(^DPT(PSUDMDFN,0)) S PSUREC1=$G(^DPT(PSUDMDFN,0)) 97 I $P(PSUREC1,U,21)=1 Q 98 I $E($P(PSUREC1,U,9),1,5)="00000" Q 99 D DEM^VADPT 100 D ELIG^VADPT 101 ;RUN DATE 102 S $P(PSUREC,U,3)=PSURDT 103 ;Gender 104 S PSUREC3=$TR($P(PSUREC1,U,2),"^","'"),$P(PSUREC,U,8)=PSUREC3 105 ;SSN 106 S PSUREC4=$TR($P(PSUREC1,U,9),"^","'"),$P(PSUREC,U,12)=PSUREC4 107 ;DOB 108 S PSUREC5=$TR($P(PSUREC1,U,3),"^","'"),$P(PSUREC,U,5)=PSUREC5 109 ;DT PT ENTERED IN FILE 110 S PSUREC6=$TR($P(PSUREC1,U,16),"^","'"),$P(PSUREC,U,16)=PSUREC6 111 S PSUREC7=$G(^PS(55,PSUDMDFN,0)),$P(PSUREC,U,17)=$TR($P(PSUREC7,U,7),"^","'") 112 ;Service Actual/Historical 113 S $P(PSUREC,U,18)=$TR($P(PSUREC7,U,8),"^","'") 114 ;PLACE "^" AT END OF RECORD 115 S $P(PSUREC,U,30)="" 116 ;SITE SENDING DATA 117 S $P(PSUREC,U,2)=PSUSNDR 118 ;RACE 119 S PSUREC8=$P($G(VADM(8)),U,2),$P(PSUREC,U,7)=PSUREC8 120 ;PRIMARY ELIG CODE 121 S PSUREC9=$P($G(VAEL(1)),U,2),$P(PSUREC,U,9)=PSUREC9 122 D PRIO 123 ;MEANS TEST STATUS 124 S PSUREC11=$P($G(VAEL(9)),U,2),$P(PSUREC,U,10)=PSUREC11 125 D MISC 126 ;FIND PATIENT ICN-VMP 127 D ICN 128 ;PATIENT CURRENT AGE 129 S PSUREC12=$G(VADM(4)),$P(PSUREC,U,6)=PSUREC12 130 D ETH 131 S ^XTMP("PSU_"_PSUJOB,"PSUDMX",PSUDMDFN)=$G(PSUREC) 132 Q 133 ; 134 PRIO ;Pull Enrollment Priority 135 ; 136 S PSUEC=0 137 F S PSUEC=$O(^DGEN(27.11,"C",PSUDMDFN,PSUEC)) Q:PSUEC="" D 138 .S PSUREC10=$TR($P($G(^DGEN(27.11,PSUEC,0)),U,7),"^","'") 139 .I PSUREC10'="" S $P(PSUREC,U,11)=PSUREC10 140 Q 141 ; 142 MISC ;Pulls miscellaneous additional info via EN^DIQ1 call 143 ;Pulls Date of Death, ICN, Primary Care Provider SSN, 144 ;Date patient first provided pharmacy care 145 ; 146 N PSUDATMP,PSUDDTMP,PSUDTMPA 147 ; 148 S PSUDTMPA=$$OUTPTPR^SDUTL3(PSUDMDFN) ;Prov IEN^EXTERNAL VALUE in temp variable 149 S PSUDATMP=$P($G(PSUDTMPA),U) ;Prov IEN 150 S $P(PSUREC,U,15)=PSUDATMP 151 I '$D(PSUDATMP)!PSUDATMP=0 S PSUDATMP=99999999999 152 S $P(PSUREC,U,14)=$$GET1^DIQ(200,PSUDATMP,9,"I") ;Prov SSN 153 S $P(PSUREC,U,4)=$S(PSUDOD:PSUDOD\1,1:"") 154 Q 155 ; 156 ICN ;Find patient ICN 157 ;VMP - OIFO BAY PINES;ELR;PSU*3.0*24 158 ; 159 N PSUICN,PSUICN1 160 S PSUICN=$$GETICN^MPIF001(PSUDMDFN) D 161 .I PSUICN'[-1 D 162 ..S $P(PSUREC,U,13)=PSUICN ;ICN 163 Q 164 ; 165 ETH ;Ethnicity and multiple race entries 166 ; 167 S PSUREC14=$P($G(VADM(11,1)),U,2),$P(PSUREC,U,19)=PSUREC14 168 ; 169 S PSURCE=0,C=20,$P(PSUREC,U,C)="" 170 F S PSURCE=$O(VADM(12,PSURCE)) Q:PSURCE="" D ;Race multiple 171 .S PSURAC=$P($G(VADM(12,PSURCE)),U,2),$P(PSUREC,U,C)=PSURAC,C=C+1 172 Q 173 ; 174 XMD ;Format mailman message and send. 175 ; 176 S PSUAB=0,PSUPL=1 177 F S PSUAB=$O(^XTMP("PSU_"_PSUJOB,"PSUDMX",PSUAB)) Q:PSUAB="" D 178 .M ^XTMP("PSU_"_PSUJOB,"PSUDM",PSUPL)=^XTMP("PSU_"_PSUJOB,"PSUDMX",PSUAB) ;Global numerical order 179 .S PSUPL=PSUPL+1 180 ; 181 NEW PSUMAX,PSULC,PSUTMC,PSUTLC,PSUMC 182 S PSUMAX=$$VAL^PSUTL(4.3,1,8.3) 183 S PSUMAX=$S(PSUMAX="":10000,PSUMAX>10000:10000,1:PSUMAX) 184 S PSUMC=1,PSUMLC=0 185 F PSULC=1:1 S X=$G(^XTMP("PSU_"_PSUJOB,"PSUDM",PSULC)) Q:X="" D 186 .S PSUMLC=PSUMLC+1 187 .I PSUMLC>PSUMAX S PSUMC=PSUMC+1,PSUMLC=0,PSULC=PSULC-1 Q ; + message 188 .I $L(X)<235 S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=X Q 189 .F I=235:-1:1 S Z=$E(X,I) Q:Z="^" 190 .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=$E(X,1,I) 191 .S PSUMLC=PSUMLC+1 192 .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)="*"_$E(X,I+1,999) 193 ; 194 ; Count Lines sent 195 S PSUTLC=0 196 F PSUM=1:1:PSUMC S X=$O(^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUM,""),-1),PSUTLC=PSUTLC+X 197 ; 198 F PSUM=1:1:PSUMC D PDMAIL^PSUDEM5 199 D CONF 200 Q 201 CONF ;Construct globals for confirmation message 202 ; 203 N PSUDIVIS 204 D INST 205 S PSUDIVIS=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1) 206 S PSUSUB="PSU_"_PSUJOB 207 S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,7,"M")=PSUMC 208 S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,7,"L")=PSUTLC 209 Q 210 REC ;EN If "^" is contained in any record, replace it with "'" 211 ; 212 I PSUREC["^" S PSUREC=$TR(PSUREC,"^","'") 213 Q 1 PSUDEM1 ;BIR/DAM - Patient Demographics Extract ; 20 DEC 2001 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005 3 ; 4 ;DBIA's 5 ; Reference to file #27.11 supported by DBIA 2462 6 ; Reference to file 2 supported by DBIA 10035, 3504 7 ; Reference to file 200 supported by DBIA 10060 8 ; Reference to file 55 supported by DBIA 3502 9 ; Reference to file 4.3 supported by DBIA 2496, 10091 10 ; Reference to file 4 supported by DBIA 10090 11 ; 12 EN ;EN Routine control module 13 ; 14 D DAT 15 I $D(^XTMP("PSUMANL")) D DEM ;Manual entry point DAM 16 I $G(^XTMP("PSU_"_PSUJOB,"PSUPSUMFLAG")) D HL7 ;Auto entry point DAM 17 I '$D(^XTMP("PSU_"_PSUJOB,"PSUFLAG")) D XMD 18 K ^XTMP("PSU_"_PSUJOB,"PSUXMD") 19 ; 20 I $G(^XTMP("PSU_"_PSUJOB,"PSUPSUMFLAG"))=1 D 21 .S PSUOPTS="1,2,3,4,5,6,7,8,9,10,11" 22 .S PSUAUTO=1 23 ; 24 ; 25 D PULL^PSUCP 26 F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))="" 27 ; 28 I $D(PSUMOD(10)) D PDSSN^PSUDEM4 ;pt. demographics provider msg 29 ; 30 K ^XTMP("PSU_"_PSUJOB,"PSUPDFLAG") 31 K ^XTMP("PSU_"_PSUJOB,"PSUDM") 32 K ^XTMP("PSU_"_PSUJOB,"PSUDMX") 33 K PSUDMDFN,PSURAC,PSURDT 34 Q 35 ; 36 HL7 ;This is the Patient Demographics extract that runs only when 37 ;the PSU PBM [AUTO] option is executed. It captures demographic 38 ;information ONLY on new or updated patient. 39 ; 40 F S PSUSDT=$O(^PSUDEM("B",PSUSDT)) Q:PSUSDT>PSUEDT D 41 . S I="" 42 . S I=$O(^PSUDEM("B",PSUSDT,I)) Q:I="" 43 . S DFN=$P(^PSUDEM(I,0),U,2) 44 . S ^XTMP("PSU"_PSUJOB,"REXMT",DFN)="" 45 K DFN 46 ; 47 S DFN="" 48 F S (DFN,PSUDMDFN)=$O(^XTMP("PSU"_PSUJOB,"REXMT",DFN)) Q:DFN="" D DEM1 49 ; 50 Q 51 ; 52 DAT ;Date Module 53 ; 54 ;Date extract was run 55 S %H=$H 56 D YMD^%DTC ;Converts $H to FileMan format 57 ; ** S $P(^TMP("PSUDM",$J),U,3)=X ;Set extract date in temp global 58 S PSURDT=X 59 ; 60 Q 61 ; 62 INST ;EN Place institution code sending report into temp global. 63 ;Institution Mailman info is in file 4.3 64 ; 65 S X=$$VALI^PSUTL(4.3,1,217),PSUSNDR=+$$VAL^PSUTL(4,X,99) 66 S $P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)=PSUSNDR 67 S PSUSIT=PSUSNDR 68 ; 69 S X=PSUSNDR,DIC=40.8,DIC(0)="X",D="C" D IX^DIC ;**1 70 S X=+Y S PSUDIVNM=$$VAL^PSUTL(40.8,X,.01) 71 S $P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,2)=PSUDIVNM 72 Q 73 ; 74 DEM ;PULL PATIENT DEMOGRAPHICS. This is run only when user selects 75 ;PSU PBM [MANUAL] option. It gather patient demographic information 76 ;for all patients in the PATIENT file #2. 77 ; 78 ;N PSUREC ;DAM TEST NEW CODE 79 N PSUREC 80 K PSUREC1,PSUREC2,PSUREC3,PSUREC4,PSUREC5,PSUREC6,PSUREC7 81 K PSUREC8,PSUREC9,PSUREC10,PSUREC11,PSUREC12,PSUREC13,PSUREC14 82 K PSUREC15,PSUDOD,VAEL,VADM 83 ; 84 S PSUNAM=0 85 F S PSUNAM=$O(^DPT("B",PSUNAM)) Q:PSUNAM="" D 86 .S PSUDMDFN=0 87 .F S (DFN,PSUDMDFN)=$O(^DPT("B",PSUNAM,PSUDMDFN)) Q:PSUDMDFN="" D DEM1 88 Q 89 ; 90 DEM1 ; 91 K PSUREC,PSUREC1,PSUREC2,PSUREC3,PSUREC4,PSUREC5,PSUREC6,PSUREC7 92 K PSUREC8,PSUREC9,PSUREC10,PSUREC11,PSUREC12,PSUREC13,PSUREC14 93 K PSUREC15,PSUDOD,VAEL,VADM 94 S PSUDOD=$P($G(^DPT(PSUDMDFN,.35)),U,1) I PSUDOD,PSUDOD<2980701 Q 95 Q:'$D(^DPT(PSUDMDFN,0)) S PSUREC1=$G(^DPT(PSUDMDFN,0)) 96 I $P(PSUREC1,U,21)=1 Q 97 I $E($P(PSUREC1,U,9),1,5)="00000" Q 98 D DEM^VADPT 99 D ELIG^VADPT 100 ;RUN DATE 101 S $P(PSUREC,U,3)=PSURDT 102 ;Gender 103 S PSUREC3=$TR($P(PSUREC1,U,2),"^","'"),$P(PSUREC,U,8)=PSUREC3 104 ;SSN 105 S PSUREC4=$TR($P(PSUREC1,U,9),"^","'"),$P(PSUREC,U,12)=PSUREC4 106 ;DOB 107 S PSUREC5=$TR($P(PSUREC1,U,3),"^","'"),$P(PSUREC,U,5)=PSUREC5 108 ;DT PT ENTERED IN FILE 109 S PSUREC6=$TR($P(PSUREC1,U,16),"^","'"),$P(PSUREC,U,16)=PSUREC6 110 S PSUREC7=$G(^PS(55,PSUDMDFN,0)),$P(PSUREC,U,17)=$TR($P(PSUREC7,U,7),"^","'") 111 ;Service Actual/Historical 112 S $P(PSUREC,U,18)=$TR($P(PSUREC7,U,8),"^","'") 113 ;PLACE "^" AT END OF RECORD 114 S $P(PSUREC,U,30)="" 115 ;SITE SENDING DATA 116 S $P(PSUREC,U,2)=PSUSNDR 117 ;RACE 118 S PSUREC8=$P($G(VADM(8)),U,2),$P(PSUREC,U,7)=PSUREC8 119 ;PRIMARY ELIG CODE 120 S PSUREC9=$P($G(VAEL(1)),U,2),$P(PSUREC,U,9)=PSUREC9 121 D PRIO 122 ;MEANS TEST STATUS 123 S PSUREC11=$P($G(VAEL(9)),U,2),$P(PSUREC,U,10)=PSUREC11 124 D MISC 125 ;FIND PATIENT ICN-VMP 126 D ICN 127 ;PATIENT CURRENT AGE 128 S PSUREC12=$G(VADM(4)),$P(PSUREC,U,6)=PSUREC12 129 D ETH 130 S ^XTMP("PSU_"_PSUJOB,"PSUDMX",PSUDMDFN)=$G(PSUREC) 131 Q 132 ; 133 PRIO ;Pull Enrollment Priority 134 ; 135 S PSUEC=0 136 F S PSUEC=$O(^DGEN(27.11,"C",PSUDMDFN,PSUEC)) Q:PSUEC="" D 137 .S PSUREC10=$TR($P($G(^DGEN(27.11,PSUEC,0)),U,7),"^","'") 138 .I PSUREC10'="" S $P(PSUREC,U,11)=PSUREC10 139 Q 140 ; 141 MISC ;Pulls miscellaneous additional info via EN^DIQ1 call 142 ;Pulls Date of Death, ICN, Primary Care Provider SSN, 143 ;Date patient first provided pharmacy care 144 ; 145 N PSUDATMP,PSUDDTMP,PSUDTMPA 146 ; 147 S PSUDTMPA=$$OUTPTPR^SDUTL3(PSUDMDFN) ;Prov IEN^EXTERNAL VALUE in temp variable 148 S PSUDATMP=$P($G(PSUDTMPA),U) ;Prov IEN 149 S $P(PSUREC,U,15)=PSUDATMP 150 I '$D(PSUDATMP)!PSUDATMP=0 S PSUDATMP=99999999999 151 S $P(PSUREC,U,14)=$$GET1^DIQ(200,PSUDATMP,9,"I") ;Prov SSN 152 S $P(PSUREC,U,4)=$S(PSUDOD:PSUDOD\1,1:"") 153 Q 154 ; 155 ICN ;Find patient ICN 156 ;VMP - OIFO BAY PINES;ELR;PSU*3.0*24 157 ; 158 N PSUICN,PSUICN1 159 S PSUICN=$$GETICN^MPIF001(PSUDMDFN) D 160 .I PSUICN'[-1 D 161 ..S $P(PSUREC,U,13)=PSUICN ;ICN 162 Q 163 ; 164 ETH ;Ethnicity and multiple race entries 165 ; 166 S PSUREC14=$P($G(VADM(11,1)),U,2),$P(PSUREC,U,19)=PSUREC14 167 ; 168 S PSURCE=0,C=20,$P(PSUREC,U,C)="" 169 F S PSURCE=$O(VADM(12,PSURCE)) Q:PSURCE="" D ;Race multiple 170 .S PSURAC=$P($G(VADM(12,PSURCE)),U,2),$P(PSUREC,U,C)=PSURAC,C=C+1 171 Q 172 ; 173 XMD ;Format mailman message and send. 174 ; 175 S PSUAB=0,PSUPL=1 176 F S PSUAB=$O(^XTMP("PSU_"_PSUJOB,"PSUDMX",PSUAB)) Q:PSUAB="" D 177 .M ^XTMP("PSU_"_PSUJOB,"PSUDM",PSUPL)=^XTMP("PSU_"_PSUJOB,"PSUDMX",PSUAB) ;Global numerical order 178 .S PSUPL=PSUPL+1 179 ; 180 NEW PSUMAX,PSULC,PSUTMC,PSUTLC,PSUMC 181 S PSUMAX=$$VAL^PSUTL(4.3,1,8.3) 182 S PSUMAX=$S(PSUMAX="":10000,PSUMAX>10000:10000,1:PSUMAX) 183 S PSUMC=1,PSUMLC=0 184 F PSULC=1:1 S X=$G(^XTMP("PSU_"_PSUJOB,"PSUDM",PSULC)) Q:X="" D 185 .S PSUMLC=PSUMLC+1 186 .I PSUMLC>PSUMAX S PSUMC=PSUMC+1,PSUMLC=0,PSULC=PSULC-1 Q ; + message 187 .I $L(X)<235 S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=X Q 188 .F I=235:-1:1 S Z=$E(X,I) Q:Z="^" 189 .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=$E(X,1,I) 190 .S PSUMLC=PSUMLC+1 191 .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)="*"_$E(X,I+1,999) 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 F PSUM=1:1:PSUMC D PDMAIL^PSUDEM5 198 D CONF 199 Q 200 CONF ;Construct globals for confirmation message 201 ; 202 N PSUDIVIS 203 D INST 204 S PSUDIVIS=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1) 205 S PSUSUB="PSU_"_PSUJOB 206 S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,7,"M")=PSUMC 207 S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,7,"L")=PSUTLC 208 Q 209 REC ;EN If "^" is contained in any record, replace it with "'" 210 ; 211 I PSUREC["^" S PSUREC=$TR(PSUREC,"^","'") 212 Q -
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 -
WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSULRHL1.m
r613 r623 1 PSULRHL1 ;HCIOFO/BH/RDC - Process real time HL7 Lab messages ; 8/1/07 11:26am 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**3,11**;MARCH, 2005;Build 8 3 ; 4 ; DBIA 3565 to subscribe to the LR7O ALL EVSEND RESULTS protocol 5 ; DBIA 998 to dig through ^DPT(i,"LR" go get the ien to file #63 6 ; DBIA 91-A to dig through ^LAB(60 to get the name of the test 7 ; DBIA 3630 to call the HL7 PID builder 8 ; DBIA 4727 to call EN^HLOCNRT 9 ; DBIA 3646 to call API: $$EMPL^DGSEC4 10 ; DBIA 4658 to call API: $$TSTRES^LRRPU 11 ; 12 ; This program is called when a lab test is verified. If it is for a 13 ; chemistry test, and not for an employee, an HL7 message will be 14 ; created and sent to the CMOP-NAT server. 15 ; 16 ; 17 HL7 ; Entry point for PBM processing - triggered by lab protocol 18 ; LR7O ALL EVSEND RESULTS. 19 ; 20 N ARR,FIRST,LRDFN,PSUEXT,PSUHLFS,PSUHLECH,PSUHLCS 21 ; 22 ; OREMSG is the pointer reference to the global that contains the 23 ; lab data and is passed in by the LR7O ALL EVSEND RESULTS protocol. 24 ; 25 I '$D(@OREMSG) Q 26 ; 27 ; Get Lab parameters 28 ; 29 D INIT^HLFNC2("PSU-SITE-DRIVER",.PSUHL) 30 ; 31 ; Set up CS delimeter for the Pharmacy message 32 ; 33 S PSUHL("CS")=$E(PSUHL("ECH"),1) 34 ; 35 ; Set up segment processing parameters 36 ; 37 S PSUEXT("PSUBUF")=$NA(^TMP("HLS",$J)) 38 S PSUEXT("PSUPTR")=0 39 ; 40 ; Get the delimiters that the passed in lab data is using 41 ; 42 D PARAMS 43 S PSUHLECH=$G(ARR("PSUHLECH"),"^~\&") 44 S PSUHLCS=$E(PSUHLECH,1) 45 ; 46 ; Quit if no DFN 47 ; 48 I '$D(ARR) Q 49 I ARR("DFN")=0!(ARR("DFN")="") Q 50 ; 51 ; Quit if patient is an employee 52 ; 53 I $$EMPL^DGSEC4(ARR("DFN"),"PS") Q 54 ; 55 ; Get Lab's equivalent of a DFN (LRDFN) 56 ; 57 S LRDFN=$P(^DPT(ARR("DFN"),"LR"),"^") ; DBIA 998 to get file #63 ien 58 ; 59 ; Loop through the lab data 60 ; 61 S FIRST=1 62 D LOOP 63 ; 64 ; Generate an HL7 if data exists to be sent 65 ; 66 I 'FIRST D GENERATE 67 ; 68 K PSUHL,ERR,OPTNS,ERR 69 ; 70 Q 71 ; 72 LOOP ; 73 N CNT,LRIDT,LRSS,PREV1,PREV2,QUIT1,QUIT2,REC,REC1,REC2,SEG,SEG1,SEG2,STR1 74 K ^TMP("HLS",$J) 75 S CNT=0 76 F Q:CNT="" S CNT=$O(@OREMSG@(CNT)) Q:'CNT D 77 . S REC=@OREMSG@(CNT) 78 . S REC=$$STRING(REC,CNT) 79 . S SEG=$P(REC,PSUHLFS,1) 80 . I SEG'="ORC" Q 81 . S STR1=$P(REC,PSUHLFS,4) 82 . S STR1=$P(STR1,PSUHLCS,1) 83 . S LRSS=$P(STR1,";",4) 84 . ; 85 . ; Quit if data is not for Chemistry 86 . ; 87 . I LRSS'="CH" Q 88 . S LRIDT=$P(STR1,";",5) 89 . S QUIT1=0 90 . F Q:QUIT1!(CNT="") S PREV1=CNT,CNT=$O(@OREMSG@(CNT)) Q:'CNT D 91 . . S REC1=@OREMSG@(CNT) 92 . . S REC1=$$STRING(REC1,CNT) 93 . . S SEG1=$P(REC1,PSUHLFS,1) 94 . . I SEG1="ORC" S CNT=PREV1,QUIT1=1 Q 95 . . I SEG1'="OBR" Q 96 . . ; If this is the first OBR being processed i.e. this is valid 97 . . ; chemistry data set the PID segment 98 . . I FIRST D PID S FIRST=0 99 . . D OBR(REC1) 100 . . S QUIT2=0 101 . . F Q:QUIT2 S PREV2=CNT,CNT=$O(@OREMSG@(CNT)) Q:'CNT D 102 . . . S REC2=@OREMSG@(CNT) 103 . . . S REC2=$$STRING(REC2,CNT) 104 . . . S SEG2=$P(REC2,PSUHLFS,1) 105 . . . I SEG2="OBR"!(SEG2="ORC") S CNT=PREV2,QUIT2=1 Q 106 . . . I SEG2'="OBX" Q 107 . . . D OBX(REC2) 108 Q 109 ; 110 PID ; Create the PID segment using the standard builder 111 ; 112 N K1,NEWSEG,SEG 113 S SEG="SEG" 114 D BLDPID^VAFCQRY(ARR("DFN"),1,"1,2,3",.SEG,.PSUHL,.ERR) 115 ; 116 ; Loop through the returned array just in case the data is spread over 117 ; more than one node 118 ; 119 S K1="",NEWSEG="" 120 F S K1=$O(SEG(K1)) Q:'K1 D 121 . S NEWSEG=NEWSEG_SEG(K1) 122 ; 123 ; Set the data string into the PBM HL7 array 124 ; 125 D SETSEG(NEWSEG) 126 ; 127 Q 128 ; 129 OBR(REC) ; Re-forms lab OBR to only send required data 130 ; 131 N OBRSEG,SITE,SPECDATE 132 S OBRSEG="OBR" 133 S SPECDATE=$P(REC,PSUHLFS,8) 134 S SITE=$P(REC,PSUHLFS,16) 135 S SITE=$TR(SITE,PSUHLCS,PSUHL("CS")) 136 ; 137 ; Create new OBR Segment and pass to SETSEG 138 ; 139 S $P(OBRSEG,PSUHL("FS"),8)=SPECDATE 140 S $P(OBRSEG,PSUHL("FS"),16)=SITE 141 ; 142 ; Set the data string into the PBM HL7 array 143 ; 144 D SETSEG(OBRSEG) 145 ; 146 Q 147 ; 148 OBX(REC) ; Reforms lab OBX to only send the data needed 149 N CODES,HRANGE,LABS,LNAME,LR60,LRANGE,LRDN,LOINC,LOINCS,P2,P3,P12,RANGE,RES,RESULTS,SEG,UNITS 150 ; 151 S P2=$P(REC,PSUHLFS,2) 152 S P3=$P(REC,PSUHLFS,3) 153 S P12=$P(REC,PSUHLFS,12) 154 S RESULTS=$P(REC,PSUHLFS,6) 155 S UNITS=$P(REC,PSUHLFS,7) 156 S LABS=$P(REC,PSUHLFS,4) 157 S LR60=$P(LABS,"^",4) 158 I LR60']"" Q 159 S LRDN=$G(^LAB(60,LR60,0)) 160 S LRDN=$P($P(LRDN,"^",5),";",2) ; DBIA 91 for data name 161 ; 162 ; Make the call to LRRPU to get the LOINC code for this test 163 ; 164 I LRDN']"" Q 165 S RES=$$TSTRES^LRRPU(LRDFN,LRSS,LRIDT,LRDN,LR60,1) 166 ; 167 S CODES=$P(RES,U,8),LOINCS=$P(CODES,"!",3) 168 S LOINC=$P(LOINCS,";",1),LNAME=$P(LOINCS,";",2) 169 S LRANGE=$P(RES,U,3),HRANGE=$P(RES,U,4) 170 S RANGE=LRANGE_"-"_HRANGE I RANGE="-" S RANGE="" 171 ; 172 ; Use the Pharmacy HL7 delimeters 173 ; 174 S LABS=$TR(LABS,PSUHLCS,PSUHL("CS")) 175 ; 176 ; Add LOINC to the list of Labs if it exists 177 ; 178 I LOINC'="" D 179 . ; 180 . ; Append the LOINC data using the pharmacy delimiters 181 . S LABS=LABS_PSUHL("CS")_LOINC_PSUHL("CS")_LNAME_PSUHL("CS")_"99LN" 182 ; 183 ; Put the data in the string 184 ; 185 S SEG="OBX" 186 S $P(SEG,PSUHL("FS"),2)=P2 187 S $P(SEG,PSUHL("FS"),3)=P3 188 S $P(SEG,PSUHL("FS"),4)=LABS 189 S $P(SEG,PSUHL("FS"),6)=RESULTS 190 S $P(SEG,PSUHL("FS"),7)=UNITS 191 S $P(SEG,PSUHL("FS"),8)=RANGE 192 S $P(SEG,PSUHL("FS"),12)=P12 193 ; 194 ; Put the string into the PBM HL7 global 195 ; 196 D SETSEG(SEG) 197 ; 198 Q 199 ; 200 STRING(HLSTR,CNT) ; Loops through sub nodes to create a full data string 201 N J 202 S J="" 203 F S J=$O(@OREMSG@(CNT,J)) Q:J="" S HLSTR=HLSTR_@OREMSG@(CNT,J) 204 Q HLSTR 205 ; 206 PARAMS ; Get the delimiters used in the lab data 207 ; 208 N CNT,ID,QUIT,REC,RES 209 K ARR 210 S (QUIT,CNT)=0,RES="" 211 F S CNT=$O(@OREMSG@(CNT)) Q:'CNT!(QUIT=2) D 212 . S REC=@OREMSG@(CNT) 213 . I $E(REC,1,3)="MSH" D Q 214 . . S PSUHLFS=$E(REC,4,4) 215 . . S ARR("PSUHLECH")=$P(REC,PSUHLFS,2),QUIT=QUIT+1 216 . I $P(REC,PSUHLFS,1)="PID" D Q 217 . . S ARR("DFN")=$P(REC,PSUHLFS,4) 218 . . S QUIT=QUIT+1 219 Q 220 ; 221 GENERATE ; Generate HL7 message 222 ; 223 ; D GENERATE^HLMA("PSU-SITE-DRIVER","GM",1,.RESULT,"",.OPTNS) 224 S OPTNS("QUEUE")="PBM LAB" 225 S RESULT=$$EN^HLOCNRT("PSU-SITE-DRIVER","GM",.OPTNS) 226 I +RESULT'=RESULT D 227 . S ^XTMP("PBM/HLO",DT,$J)=RESULT 228 K ^TMP("HLS",$J) 229 Q 230 ; 231 ; 232 SETSEG(SEG) ; 233 ; 234 ;***** STORES THE SEGMENT INTO THE ^TMP("HLS",$J) BUFFER 235 ; 236 ; SEG HL7 segment 237 ; 238 ; The SETSEG procedure stores the HL7 segment into the 239 ; standard HL7 buffer ^TMP("HLS",$J). The <TAB>, <CR> and <LF> 240 ; characters are replaced with spaces. Long segments are split among 241 ; sub-nodes of the main segment node. 242 ; 243 ; The PSUEXT array must be initialized before 244 ; calling this function. 245 ; 246 N I1,I2,MAXLEN,NODE,PTR,PTR1,SID,SL 247 S NODE=PSUEXT("PSUBUF"),PTR=$G(PSUEXT("PSUPTR"))+1 248 S SL=$L(SEG),MAXLEN=245 K @NODE@(PTR) 249 ;--- Store the segment 250 S @NODE@(PTR)=$TR($E(SEG,1,MAXLEN),$C(9,10,13)," ") 251 ; 252 ;--- Split the segment into sub-nodes if necessary 253 D:SL>MAXLEN 254 . S I2=MAXLEN 255 . F PTR1=1:1 S I1=I2+1,I2=I1+MAXLEN-1 Q:I1>SL D 256 . . S @NODE@(PTR,PTR1)=$TR($E(SEG,I1,I2),$C(9,10,13)," ") 257 ;--- Save the pointer 258 S PSUEXT("PSUPTR")=PTR 259 Q 1 PSULRHL1 ;HCIOFO/BH/RDC - Process real time HL7 Lab messages ; 5/15/04 3:10pm 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**3**;MARCH, 2005 3 ; 4 ; DBIA 3565 to subscribe to the LR7O ALL EVSEND RESULTS protocol 5 ; DBIA 998 to dig through ^DPT(i,"LR" go get the ien to file #63 6 ; DBIA 91-A to dig through ^LAB(60 to get the name of the test 7 ; DBIA 3630 to call the HL7 PID builder 8 ; DBIA 4727 to call EN^HLOCNRT 9 ; DBIA 3646 to call API: $$EMPL^DGSEC4 10 ; DBIA 4658 to call API: $$TSTRES^LRRPU 11 ; 12 ; This program is called when a lab test is verified. If it is for a 13 ; chemistry test, and not for an employee, an HL7 message will be 14 ; created and sent to the CMOP-NAT server. 15 ; 16 ; 17 HL7 ; Entry point for PBM processing - triggered by lab protocol 18 ; LR7O ALL EVSEND RESULTS. 19 ; 20 N ARR,FIRST,LRDFN,PSUEXT,PSUHLFS,PSUHLECH,PSUHLCS 21 ; 22 ; OREMSG is the pointer reference to the global that contains the 23 ; lab data and is passed in by the LR7O ALL EVSEND RESULTS protocol. 24 ; 25 I '$D(@OREMSG) Q 26 ; 27 ; Get Lab parameters 28 ; 29 D INIT^HLFNC2("PSU-SITE-DRIVER",.PSUHL) 30 ; 31 ; Set up CS delimeter for the Pharmacy message 32 ; 33 S PSUHL("CS")=$E(PSUHL("ECH"),1) 34 ; 35 ; Set up segment processing parameters 36 ; 37 S PSUEXT("PSUBUF")=$NA(^TMP("HLS",$J)) 38 S PSUEXT("PSUPTR")=0 39 ; 40 ; Get the delimiters that the passed in lab data is using 41 ; 42 D PARAMS 43 S PSUHLECH=$G(ARR("PSUHLECH"),"^~\&") 44 S PSUHLCS=$E(PSUHLECH,1) 45 ; 46 ; Quit if no DFN 47 ; 48 I '$D(ARR) Q 49 I ARR("DFN")=0!(ARR("DFN")="") Q 50 ; 51 ; Quit if patient is an employee 52 ; 53 I $$EMPL^DGSEC4(ARR("DFN"),"PS") Q 54 ; 55 ; Get Lab's equivalent of a DFN (LRDFN) 56 ; 57 S LRDFN=$P(^DPT(ARR("DFN"),"LR"),"^") ; DBIA 998 to get file #63 ien 58 ; 59 ; Loop through the lab data 60 ; 61 S FIRST=1 62 D LOOP 63 ; 64 ; Generate an HL7 if data exists to be sent 65 ; 66 I 'FIRST D GENERATE 67 ; 68 K PSUHL,ERR,OPTNS,ERR 69 ; 70 Q 71 ; 72 LOOP ; 73 N CNT,LRIDT,LRSS,PREV1,PREV2,QUIT1,QUIT2,REC,REC1,REC2,SEG,SEG1,SEG2,STR1 74 K ^TMP("HLS",$J) 75 S CNT=0 76 F Q:CNT="" S CNT=$O(@OREMSG@(CNT)) Q:'CNT D 77 . S REC=@OREMSG@(CNT) 78 . S REC=$$STRING(REC,CNT) 79 . S SEG=$P(REC,PSUHLFS,1) 80 . I SEG'="ORC" Q 81 . S STR1=$P(REC,PSUHLFS,4) 82 . S STR1=$P(STR1,PSUHLCS,1) 83 . S LRSS=$P(STR1,";",4) 84 . ; 85 . ; Quit if data is not for Chemistry 86 . ; 87 . I LRSS'="CH" Q 88 . S LRIDT=$P(STR1,";",5) 89 . S QUIT1=0 90 . F Q:QUIT1!(CNT="") S PREV1=CNT,CNT=$O(@OREMSG@(CNT)) Q:'CNT D 91 . . S REC1=@OREMSG@(CNT) 92 . . S REC1=$$STRING(REC1,CNT) 93 . . S SEG1=$P(REC1,PSUHLFS,1) 94 . . I SEG1="ORC" S CNT=PREV1,QUIT1=1 Q 95 . . I SEG1'="OBR" Q 96 . . ; If this is the first OBR being processed i.e. this is valid 97 . . ; chemistry data set the PID segment 98 . . I FIRST D PID S FIRST=0 99 . . D OBR(REC1) 100 . . S QUIT2=0 101 . . F Q:QUIT2 S PREV2=CNT,CNT=$O(@OREMSG@(CNT)) Q:'CNT D 102 . . . S REC2=@OREMSG@(CNT) 103 . . . S REC2=$$STRING(REC2,CNT) 104 . . . S SEG2=$P(REC2,PSUHLFS,1) 105 . . . I SEG2="OBR"!(SEG2="ORC") S CNT=PREV2,QUIT2=1 Q 106 . . . I SEG2'="OBX" Q 107 . . . D OBX(REC2) 108 Q 109 ; 110 PID ; Create the PID segment using the standard builder 111 ; 112 N K1,NEWSEG,SEG 113 S SEG="SEG" 114 D BLDPID^VAFCQRY(ARR("DFN"),1,"1,2,3",.SEG,.PSUHL,.ERR) 115 ; 116 ; Loop through the returned array just in case the data is spread over 117 ; more than one node 118 ; 119 S K1="",NEWSEG="" 120 F S K1=$O(SEG(K1)) Q:'K1 D 121 . S NEWSEG=NEWSEG_SEG(K1) 122 ; 123 ; Set the data string into the PBM HL7 array 124 ; 125 D SETSEG(NEWSEG) 126 ; 127 Q 128 ; 129 OBR(REC) ; Re-forms lab OBR to only send required data 130 ; 131 N OBRSEG,SITE,SPECDATE 132 S OBRSEG="OBR" 133 S SPECDATE=$P(REC,PSUHLFS,8) 134 S SITE=$P(REC,PSUHLFS,16) 135 S SITE=$TR(SITE,PSUHLCS,PSUHL("CS")) 136 ; 137 ; Create new OBR Segment and pass to SETSEG 138 ; 139 S $P(OBRSEG,PSUHL("FS"),8)=SPECDATE 140 S $P(OBRSEG,PSUHL("FS"),16)=SITE 141 ; 142 ; Set the data string into the PBM HL7 array 143 ; 144 D SETSEG(OBRSEG) 145 ; 146 Q 147 ; 148 OBX(REC) ; Reforms lab OBX to only send the data needed 149 N CODES,HRANGE,LABS,LNAME,LR60,LRANGE,LRDN,LOINC,LOINCS,P2,P3,P12,RANGE,RES,RESULTS,SEG,UNITS 150 ; 151 S P2=$P(REC,PSUHLFS,2) 152 S P3=$P(REC,PSUHLFS,3) 153 S P12=$P(REC,PSUHLFS,12) 154 S RESULTS=$P(REC,PSUHLFS,6) 155 S UNITS=$P(REC,PSUHLFS,7) 156 S LABS=$P(REC,PSUHLFS,4) 157 S LR60=$P(LABS,"^",4) 158 S LRDN=$G(^LAB(60,LR60,0)) 159 S LRDN=$P($P(LRDN,"^",5),";",2) ; DBIA 91 for data name 160 ; 161 ; Make the call to LRRPU to get the LOINC code for this test 162 ; 163 S RES=$$TSTRES^LRRPU(LRDFN,LRSS,LRIDT,LRDN,LR60,1) 164 ; 165 S CODES=$P(RES,U,8),LOINCS=$P(CODES,"!",3) 166 S LOINC=$P(LOINCS,";",1),LNAME=$P(LOINCS,";",2) 167 S LRANGE=$P(RES,U,3),HRANGE=$P(RES,U,4) 168 S RANGE=LRANGE_"-"_HRANGE I RANGE="-" S RANGE="" 169 ; 170 ; Use the Pharmacy HL7 delimeters 171 ; 172 S LABS=$TR(LABS,PSUHLCS,PSUHL("CS")) 173 ; 174 ; Add LOINC to the list of Labs if it exists 175 ; 176 I LOINC'="" D 177 . ; 178 . ; Append the LOINC data using the pharmacy delimiters 179 . S LABS=LABS_PSUHL("CS")_LOINC_PSUHL("CS")_LNAME_PSUHL("CS")_"99LN" 180 ; 181 ; Put the data in the string 182 ; 183 S SEG="OBX" 184 S $P(SEG,PSUHL("FS"),2)=P2 185 S $P(SEG,PSUHL("FS"),3)=P3 186 S $P(SEG,PSUHL("FS"),4)=LABS 187 S $P(SEG,PSUHL("FS"),6)=RESULTS 188 S $P(SEG,PSUHL("FS"),7)=UNITS 189 S $P(SEG,PSUHL("FS"),8)=RANGE 190 S $P(SEG,PSUHL("FS"),12)=P12 191 ; 192 ; Put the string into the PBM HL7 global 193 ; 194 D SETSEG(SEG) 195 ; 196 Q 197 ; 198 STRING(HLSTR,CNT) ; Loops through sub nodes to create a full data string 199 N J 200 S J="" 201 F S J=$O(@OREMSG@(CNT,J)) Q:J="" S HLSTR=HLSTR_@OREMSG@(CNT,J) 202 Q HLSTR 203 ; 204 PARAMS ; Get the delimiters used in the lab data 205 ; 206 N CNT,ID,QUIT,REC,RES 207 K ARR 208 S (QUIT,CNT)=0,RES="" 209 F S CNT=$O(@OREMSG@(CNT)) Q:'CNT!(QUIT=2) D 210 . S REC=@OREMSG@(CNT) 211 . I $E(REC,1,3)="MSH" D Q 212 . . S PSUHLFS=$E(REC,4,4) 213 . . S ARR("PSUHLECH")=$P(REC,PSUHLFS,2),QUIT=QUIT+1 214 . I $P(REC,PSUHLFS,1)="PID" D Q 215 . . S ARR("DFN")=$P(REC,PSUHLFS,4) 216 . . S QUIT=QUIT+1 217 Q 218 ; 219 GENERATE ; Generate HL7 message 220 ; 221 ; D GENERATE^HLMA("PSU-SITE-DRIVER","GM",1,.RESULT,"",.OPTNS) 222 S OPTNS("QUEUE")="PBM LAB" 223 S RESULT=$$EN^HLOCNRT("PSU-SITE-DRIVER","GM",.OPTNS) 224 I +RESULT'=RESULT D 225 . S ^XTMP("PBM/HLO",DT,$J)=RESULT 226 K ^TMP("HLS",$J) 227 Q 228 ; 229 ; 230 SETSEG(SEG) ; 231 ; 232 ;***** STORES THE SEGMENT INTO THE ^TMP("HLS",$J) BUFFER 233 ; 234 ; SEG HL7 segment 235 ; 236 ; The SETSEG procedure stores the HL7 segment into the 237 ; standard HL7 buffer ^TMP("HLS",$J). The <TAB>, <CR> and <LF> 238 ; characters are replaced with spaces. Long segments are split among 239 ; sub-nodes of the main segment node. 240 ; 241 ; The PSUEXT array must be initialized before 242 ; calling this function. 243 ; 244 N I1,I2,MAXLEN,NODE,PTR,PTR1,SID,SL 245 S NODE=PSUEXT("PSUBUF"),PTR=$G(PSUEXT("PSUPTR"))+1 246 S SL=$L(SEG),MAXLEN=245 K @NODE@(PTR) 247 ;--- Store the segment 248 S @NODE@(PTR)=$TR($E(SEG,1,MAXLEN),$C(9,10,13)," ") 249 ; 250 ;--- Split the segment into sub-nodes if necessary 251 D:SL>MAXLEN 252 . S I2=MAXLEN 253 . F PTR1=1:1 S I1=I2+1,I2=I1+MAXLEN-1 Q:I1>SL D 254 . . S @NODE@(PTR,PTR1)=$TR($E(SEG,I1,I2),$C(9,10,13)," ") 255 ;--- Save the pointer 256 S PSUEXT("PSUPTR")=PTR 257 Q -
WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUMAP0.m
r613 r623 1 PSUMAP0 ;BHM/PDW-MAP OAU,NAOU,DA LOCATION TO DIVISION/OUTPATIENT SITES ; 4/12/07 2:12pm 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19 3 ; 4 ;DBIA's 5 ;Reference to file (#59.7) supported by DBIA 2854 6 ; 7 EN ; select Editing or Report of Mapping 8 W @IOF,!,?10,"MAPPING PHARMACY LOCATIONS FOR PBM EXTRACTS",!! 9 ; 10 MODP ; module selection prompt 11 W !!,?5,"This option allows the mapping of dispensing/procurement locations" 12 W !,?5,"from the AR/WS, Controlled Substances, and Drug Accountability" 13 W !,?5,"applications to either a Medical Center Division or an Outpatient Site." 14 W !,?5,"Any dispensing/procurement data associated with an AR/WS AOU, CS NAOU" 15 W !,?5,"or DA Pharmacy Location that has not been mapped will be attributed to" 16 W !,?5,"to the facility at which the database resides. Any unmapped locations" 17 W !,?5,"will be displayed upon entering the option.",! 18 ; 19 D EN1^PSUMAPR ;scan and report unmapped locations 20 W @IOF 21 ; 22 MODULE ; 23 W !!,"Select the dispensing/procurement location to map:",! 24 S PSUA(1)="1. AR/WS Area of Use (AOU)" 25 S PSUA(2)="2. Controlled Substances (CS) Narcotic Area of Use (NAOU)" 26 S PSUA(3)="3. Drug Accountability (DA) Pharmacy location" 27 S PSUA(4)="4. Print Report of Mapped/Unmapped Locations" 28 F I=1:1:4 W !,?10,PSUA(I) 29 W !!,?2,"You may select all by entering 'A' for ALL or by using '1:4'.",! 30 W !,?2,"Select the dispensing/procurement location: " 31 R X:DTIME E W !!,"Nothing Selected - Exiting",! H 3 G EXIT 32 I X["^" G EXIT:X="^" 33 I X="" W " <??>",$C(7) S X="?" 34 ; 35 S:"Aa"[$E(X) X="1:4" 36 MODHLP I X["?" D G MODULE 37 .W !!,"Enter: A single number to edit (or print) that selection." 38 .W !,?8,"A range of code numbers. Example: 1:3" 39 .W !,?8,"Multiple code numbers separated by commas. Example: 1,3" 40 .W !,?8,"The letter A to select ALL items." 41 .W !,?8,"A single up-arrow ( ^ ) to exit now without any action." 42 S X=$TR(X,"-;_><.A","::::::") 43 K PSUMOD 44 F PII=1:1:$L(X,",") D 45 .S X1=$P(X,",",PII) 46 .Q:X1="" 47 .I X1[":" D Q 48 ..S XBEG=$P(X1,":",1),XEND=$P(X1,":",2) 49 ..I (XBEG="")!(XEND="") Q 50 ..F PJJ=XBEG:1:XEND S PSUMOD(PJJ)="" 51 ..K PJJ,XBEG,XEND 52 .S PSUMOD(X1)="" 53 ; modified to fix <UNDEFINED> PSU*3*12 BAJ 54 S X="",ERC=0 F S X=$O(PSUMOD(X)) Q:X="" I '$D(PSUA(X)) S ERC=1 Q 55 I ERC W !!,"<INVALID CHOICE - ",X,", TRY AGAIN>",$C(7) G MODP 56 I '$D(PSUMOD) W !!,"No choices were made." K DIR S DIR(0)="E",DIR("A")="EXITING" D ^DIR G EXIT 57 ; 58 ; 59 W !!,"You have selected: " 60 S X="",PSUOPTS="" F S X=$O(PSUMOD(X)) Q:X="" W !,?10,PSUA(X) 61 W ! K DIR S DIR(0)="E" D ^DIR G:'Y EXIT 62 I $D(PSUMOD(4)) D REPORT K PSUA(4) 63 I $D(PSUMOD(1)) D E9001 64 I $D(PSUMOD(2)) D E9002 65 I $D(PSUMOD(3)) D E9003 66 Q 67 E9001 ;EDIT 90.01 AR/WS AOU MAPPING 68 W @IOF,!!,?20,"EDITING Mapping of AR/WS AOUs",!! 69 K DIC,DA,DIE 70 K Z,ZZ,IENS 71 S DA(1)=1 72 S DIC="^PS(59.7,1,90.01,",DA(1)=1,DIC(0)="ACEQML" 73 S DIC("W")="X XX1,XX2" 74 S XX1="S IENS=+Y_"",""_DA(1) S Z=$$GET1^DIQ(59.79001,IENS,.02),ZZ=$$GET1^DIQ(59.79001,IENS,.03) W:$L(Z) ?35,""Div: "",Z W:$L(ZZ) ?35,""OP: "",ZZ" 75 S XX2="S ZZ=$$GET1^DIQ(58.1,+Y,3,""I"") W:ZZ ?65,""**INACTIVE**""" 76 D ^DIC 77 Q:Y'>0 78 S DA=+Y,DIE=DIC 79 S ZZ=^PS(59.7,1,90.01,DA,0),XX=$P(ZZ,U,2),YY=$P(ZZ,U,3) 80 I YY S DR=".01;.03;S:X'="""" Y=0;.02" I 1 81 E S DR=".01;.02;S:X'="""" Y=0;.03" 82 D ^DIE W ! 83 G E9001 84 ; 85 CHK1 ;check that AOUs are mapped 86 K IENS 87 S DA=0,DA(1)=1 F S DA=$O(^PS(59.7,1,90.01,DA)) Q:DA'>0 D 88 . S Z=^PS(59.7,1,90.01,DA,0),X=$P(Z,U,2),Y=$P(Z,U,3) 89 . I Y,'X Q 90 . I 'Y,X Q 91 . S IENS=DA_",1" W !,?3,"AR/WS AOU",?15,$$GET1^DIQ(59.79001,IENS,.01),?25," is not mapped." 92 I $G(STOP),$G(IENS) K DIR S DIR(0)="E" D ^DIR I X="^" S PSUSTOP=1 I 1 93 Q 94 ; 95 E9002 ;EDIT 90.02 CS NAOU MAPPING 96 W @IOF,!!,?20,"EDITING Mapping of CS NAOUs",!! 97 K DIC,DA,DIE 98 K Z,ZZ,IENS 99 S DA(1)=1 100 S DIC="^PS(59.7,DA(1),90.02,",DIC(0)="AEQMLCZ" 101 S DIC("W")="X XX1,XX2" 102 S XX1="S IENS=+Y_"",""_DA(1) S Z=$$GET1^DIQ(59.79002,IENS,.02),ZZ=$$GET1^DIQ(59.79002,IENS,.03) W:$L(Z) ?35,""Div: "",Z W:$L(ZZ) ?35,""OP: "",ZZ" 103 S XX2="S ZZ=$$GET1^DIQ(58.8,+Y,4,""I"") W:ZZ ?65,""**INACTIVE** """ 104 D ^DIC 105 Q:Y'>0 106 S DA=+Y,DIE=DIC 107 S ZZ=^PS(59.7,1,90.02,DA,0),XX=$P(ZZ,U,2),YY=$P(ZZ,U,3) 108 I YY S DR=".01;.03;S:X'="""" Y=0;.02" I 1 109 E S DR=".01;.02;S:X'="""" Y=0;.03" 110 D ^DIE W ! 111 G E9002 112 ; 113 CHK2 ;check that NAOUs are mapped 114 K IENS 115 S DA=0,DA(1)=1 F S DA=$O(^PS(59.7,1,90.02,DA)) Q:DA'>0 D 116 . S Z=^PS(59.7,1,90.02,DA,0),X=$P(Z,U,2),Y=$P(Z,U,3) 117 . I Y,'X Q 118 . I 'Y,X Q 119 . S IENS=DA_",1" W !,?3,"CS NAOU",?15,$$GET1^DIQ(59.79002,IENS,.01),?25," is not mapped." 120 Q 121 E9003 ;EDIT 90.03 DRUG ACCOUNTABILITY LOCATION MAPPING 122 W @IOF,!!,?20,"EDITING Mapping of DA Pharmacy Locations",!! 123 K DIC,DA,DIE 124 K Z,ZZ,IENS 125 S DA(1)=1 126 S DIC="^PS(59.7,DA(1),90.03,",DIC(0)="AEQMLZ" 127 S DIC("W")="X XX1,XX2" 128 S XX1="S IENS=+Y_"",""_DA(1) S Z=$$GET1^DIQ(59.79003,IENS,.02),ZZ=$$GET1^DIQ(59.79003,IENS,.03) W:$L(Z) ?35,"" Div: "",Z W:$L(ZZ) ?35,""OP: "",ZZ" 129 S XX2="S ZZ=$$GET1^DIQ(58.8,+Y,4,""I"") W:ZZ ?65,""**INACTIVE** """ 130 D ^DIC 131 Q:Y'>0 132 S DA=+Y,DIE=DIC 133 S ZZ=^PS(59.7,1,90.03,DA,0),XX=$P(ZZ,U,2),YY=$P(ZZ,U,3) 134 I YY S DR=".01;.03;S:X'="""" Y=0;.02" I 1 135 E S DR=".01;.02;S:X'="""" Y=0;.03" 136 D ^DIE W ! 137 G E9003 138 ; 139 CHK3 ;check that DRUG ACCOUNTABILITY LOCATIONs are mapped 140 K IENS 141 S DA=0,DA(1)=1 F S DA=$O(^PS(59.7,1,90.03,DA)) Q:DA'>0 D 142 . S Z=^PS(59.7,1,90.03,DA,0),X=$P(Z,U,2),Y=$P(Z,U,3) 143 . I Y,'X Q 144 . I 'Y,X Q 145 . S IENS=DA_",1" W !,?3,"DA Phar Loc",?15,$$GET1^DIQ(59.79003,IENS,.01),?25," is not mapped." 146 I $G(STOP),$G(IENS) K DIR S DIR(0)="E" D ^DIR I X="^" S PSUSTOP=1 I 1 147 Q 148 REPORT ;Print Mapping Report 149 W @IOF,!,"Print Pharmacy Location PBM Extract Mapping Report",! 150 S %ZIS="Q" D ^%ZIS 151 Q:POP 152 I $D(IO("Q")) D QUEUE Q 153 D EN^PSUMAPR 154 Q 155 QUEUE S ZTRTN="EN^PSUMAPR",ZTDESC="PRINT REPORT OF PBM EXTRACT MAPPING" 156 S ZTREQ="@" D ^%ZTLOAD 157 W !,"TASKED with ",$G(ZTSK) I '$G(ZTSK) W ">> DID NOT Task !!",! H 3 158 Q 159 EXIT ; 160 Q 1 PSUMAP0 ;BHM/PDW-MAP OAU,NAOU,DA LOCATION TO DIVISION/OUTPATIENT SITES ; 9SEP2003 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005 3 ; 4 ;DBIA's 5 ;Reference to file (#59.7) supported by DBIA 2854 6 ; 7 EN ; select Editing or Report of Mapping 8 W @IOF,!,?10,"MAPPING PHARMACY LOCATIONS FOR PBM EXTRACTS",!! 9 ; 10 MODP ; module selection prompt 11 W !!,?5,"This option allows the mapping of dispensing/procurement locations" 12 W !,?5,"from the AR/WS, Controlled Substances, and Drug Accountability" 13 W !,?5,"applications to either a Medical Center Division or an Outpatient Site." 14 W !,?5,"Any dispensing/procurement data associated with an AR/WS AOU, CS NAOU" 15 W !,?5,"or DA Pharmacy Location that has not been mapped will be attributed to" 16 W !,?5,"to the facility at which the database resides. Any unmapped locations" 17 W !,?5,"will be displayed upon entering the option.",! 18 ; 19 D EN1^PSUMAPR ;scan and report unmapped locations 20 W @IOF 21 ; 22 MODULE ; 23 W !!,"Select the dispensing/procurement location to map:",! 24 S PSUA(1)="1. AR/WS Area of Use (AOU)" 25 S PSUA(2)="2. Controlled Substances (CS) Narcotic Area of Use (NAOU)" 26 S PSUA(3)="3. Drug Accountability (DA) Pharmacy location" 27 S PSUA(4)="4. Print Report of Mapped/Unmapped Locations" 28 F I=1:1:4 W !,?10,PSUA(I) 29 W !!,?2,"You may select all by entering 'A' for ALL or by using '1:4'.",! 30 W !,?2,"Select the dispensing/procurement location: " 31 R X:DTIME E W !!,"Nothing Selected - Exiting",! H 3 G EXIT 32 I X["^" G EXIT:X="^" 33 I X="" W " <??>",$C(7) S X="?" 34 ; 35 S:"Aa"[$E(X) X="1:4" 36 MODHLP I X["?" D G MODULE 37 .W !!,"Enter: A single number to edit (or print) that selection." 38 .W !,?8,"A range of code numbers. Example: 1:3" 39 .W !,?8,"Multiple code numbers separated by commas. Example: 1,3" 40 .W !,?8,"The letter A to select ALL items." 41 .W !,?8,"A single up-arrow ( ^ ) to exit now without any action." 42 S X=$TR(X,"-;_><.A","::::::") 43 K PSUMOD 44 F PII=1:1:$L(X,",") D 45 .S X1=$P(X,",",PII) 46 .Q:X1="" 47 .I X1[":" D Q 48 ..S XBEG=$P(X1,":",1),XEND=$P(X1,":",2) 49 ..I (XBEG="")!(XEND="") Q 50 ..F PJJ=XBEG:1:XEND S PSUMOD(PJJ)="" 51 ..K PJJ,XBEG,XEND 52 .S PSUMOD(X1)="" 53 S (X,ERC)=0 F S X=$O(PSUMOD(X)) Q:X="" I '$D(PSUA(X)) S ERC=1 Q 54 I ERC W !!,"<INVALID CHOICE - ",X,", TRY AGAIN>",$C(7) G MODP 55 I '$D(PSUMOD) W !!,"No choices were made." K DIR S DIR(0)="E",DIR("A")="EXITING" D ^DIR G EXIT 56 ; 57 ; 58 W !!,"You have selected: " 59 S X="",PSUOPTS="" F S X=$O(PSUMOD(X)) Q:X="" W !,?10,PSUA(X) 60 W ! K DIR S DIR(0)="E" D ^DIR G:'Y EXIT 61 I $D(PSUMOD(4)) D REPORT K PSUA(4) 62 I $D(PSUMOD(1)) D E9001 63 I $D(PSUMOD(2)) D E9002 64 I $D(PSUMOD(3)) D E9003 65 Q 66 E9001 ;EDIT 90.01 AR/WS AOU MAPPING 67 W @IOF,!!,?20,"EDITING Mapping of AR/WS AOUs",!! 68 K DIC,DA,DIE 69 K Z,ZZ,IENS 70 S DA(1)=1 71 S DIC="^PS(59.7,1,90.01,",DA(1)=1,DIC(0)="ACEQML" 72 S DIC("W")="X XX1,XX2" 73 S XX1="S IENS=+Y_"",""_DA(1) S Z=$$GET1^DIQ(59.79001,IENS,.02),ZZ=$$GET1^DIQ(59.79001,IENS,.03) W:$L(Z) ?35,""Div: "",Z W:$L(ZZ) ?35,""OP: "",ZZ" 74 S XX2="S ZZ=$$GET1^DIQ(58.1,+Y,3,""I"") W:ZZ ?65,""**INACTIVE**""" 75 D ^DIC 76 Q:Y'>0 77 S DA=+Y,DIE=DIC 78 S ZZ=^PS(59.7,1,90.01,DA,0),XX=$P(ZZ,U,2),YY=$P(ZZ,U,3) 79 I YY S DR=".01;.03;S:X'="""" Y=0;.02" I 1 80 E S DR=".01;.02;S:X'="""" Y=0;.03" 81 D ^DIE W ! 82 G E9001 83 ; 84 CHK1 ;check that AOUs are mapped 85 K IENS 86 S DA=0,DA(1)=1 F S DA=$O(^PS(59.7,1,90.01,DA)) Q:DA'>0 D 87 . S Z=^PS(59.7,1,90.01,DA,0),X=$P(Z,U,2),Y=$P(Z,U,3) 88 . I Y,'X Q 89 . I 'Y,X Q 90 . S IENS=DA_",1" W !,?3,"AR/WS AOU",?15,$$GET1^DIQ(59.79001,IENS,.01),?25," is not mapped." 91 I $G(STOP),$G(IENS) K DIR S DIR(0)="E" D ^DIR I X="^" S PSUSTOP=1 I 1 92 Q 93 ; 94 E9002 ;EDIT 90.02 CS NAOU MAPPING 95 W @IOF,!!,?20,"EDITING Mapping of CS NAOUs",!! 96 K DIC,DA,DIE 97 K Z,ZZ,IENS 98 S DA(1)=1 99 S DIC="^PS(59.7,DA(1),90.02,",DIC(0)="AEQMLCZ" 100 S DIC("W")="X XX1,XX2" 101 S XX1="S IENS=+Y_"",""_DA(1) S Z=$$GET1^DIQ(59.79002,IENS,.02),ZZ=$$GET1^DIQ(59.79002,IENS,.03) W:$L(Z) ?35,""Div: "",Z W:$L(ZZ) ?35,""OP: "",ZZ" 102 S XX2="S ZZ=$$GET1^DIQ(58.8,+Y,4,""I"") W:ZZ ?65,""**INACTIVE** """ 103 D ^DIC 104 Q:Y'>0 105 S DA=+Y,DIE=DIC 106 S ZZ=^PS(59.7,1,90.02,DA,0),XX=$P(ZZ,U,2),YY=$P(ZZ,U,3) 107 I YY S DR=".01;.03;S:X'="""" Y=0;.02" I 1 108 E S DR=".01;.02;S:X'="""" Y=0;.03" 109 D ^DIE W ! 110 G E9002 111 ; 112 CHK2 ;check that NAOUs are mapped 113 K IENS 114 S DA=0,DA(1)=1 F S DA=$O(^PS(59.7,1,90.02,DA)) Q:DA'>0 D 115 . S Z=^PS(59.7,1,90.02,DA,0),X=$P(Z,U,2),Y=$P(Z,U,3) 116 . I Y,'X Q 117 . I 'Y,X Q 118 . S IENS=DA_",1" W !,?3,"CS NAOU",?15,$$GET1^DIQ(59.79002,IENS,.01),?25," is not mapped." 119 Q 120 E9003 ;EDIT 90.03 DRUG ACCOUNTABILITY LOCATION MAPPING 121 W @IOF,!!,?20,"EDITING Mapping of DA Pharmacy Locations",!! 122 K DIC,DA,DIE 123 K Z,ZZ,IENS 124 S DA(1)=1 125 S DIC="^PS(59.7,DA(1),90.03,",DIC(0)="AEQMLZ" 126 S DIC("W")="X XX1,XX2" 127 S XX1="S IENS=+Y_"",""_DA(1) S Z=$$GET1^DIQ(59.79003,IENS,.02),ZZ=$$GET1^DIQ(59.79003,IENS,.03) W:$L(Z) ?35,"" Div: "",Z W:$L(ZZ) ?35,""OP: "",ZZ" 128 S XX2="S ZZ=$$GET1^DIQ(58.8,+Y,4,""I"") W:ZZ ?65,""**INACTIVE** """ 129 D ^DIC 130 Q:Y'>0 131 S DA=+Y,DIE=DIC 132 S ZZ=^PS(59.7,1,90.03,DA,0),XX=$P(ZZ,U,2),YY=$P(ZZ,U,3) 133 I YY S DR=".01;.03;S:X'="""" Y=0;.02" I 1 134 E S DR=".01;.02;S:X'="""" Y=0;.03" 135 D ^DIE W ! 136 G E9003 137 ; 138 CHK3 ;check that DRUG ACCOUNTABILITY LOCATIONs are mapped 139 K IENS 140 S DA=0,DA(1)=1 F S DA=$O(^PS(59.7,1,90.03,DA)) Q:DA'>0 D 141 . S Z=^PS(59.7,1,90.03,DA,0),X=$P(Z,U,2),Y=$P(Z,U,3) 142 . I Y,'X Q 143 . I 'Y,X Q 144 . S IENS=DA_",1" W !,?3,"DA Phar Loc",?15,$$GET1^DIQ(59.79003,IENS,.01),?25," is not mapped." 145 I $G(STOP),$G(IENS) K DIR S DIR(0)="E" D ^DIR I X="^" S PSUSTOP=1 I 1 146 Q 147 REPORT ;Print Mapping Report 148 W @IOF,!,"Print Pharmacy Location PBM Extract Mapping Report",! 149 S %ZIS="Q" D ^%ZIS 150 Q:POP 151 I $D(IO("Q")) D QUEUE Q 152 D EN^PSUMAPR 153 Q 154 QUEUE S ZTRTN="EN^PSUMAPR",ZTDESC="PRINT REPORT OF PBM EXTRACT MAPPING" 155 S ZTREQ="@" D ^%ZTLOAD 156 W !,"TASKED with ",$G(ZTSK) I '$G(ZTSK) W ">> DID NOT Task !!",! H 3 157 Q 158 EXIT ; 159 Q -
WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUOPAM.m
r613 r623 1 PSUOPAM ;BIR/DAM - PSU PBM Outpatient AMIS Pharmacy Data Collection; March 2004 ; 1/11/08 11:46am 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**13**;MARCH, 2005;Build 3 3 ; 4 ;DBIA's 5 ;Reference to File (#52) supported by DBIA 1878 6 ; 7 EN ;entry point to gather additional AMIS data. Called from PSUOP2 8 ; 9 K PSUAM ;Array to hold single dose Medication Instructions 10 K PSUAMMD ;Array to hold multidose medication instructions 11 K PSUMDFLG ;Multidose flag 12 S (PSUPI,PSUCO,PSUEXP,PSUAM,PSUDSG,PSUDIPU,PSUNITS,PSUNOUN)="" 13 S (PSUDUR,PSUCONJ,PSUROUT,PSUSCHED,PSUVERB)="" 14 D CO 15 D EXP 16 D DOSG 17 Q 18 ; 19 ; 20 CO ;Copay status: found in file (#52), field (#105) 21 ; 22 ;PSU*4*13 Corrected to show the COPAY. 23 S PSUCO=$P($G(^TMP("PSOR",$J,PSURXIEN,"IB")),U,1) 24 I $G(PSUCO) S PSUCOPAY="Y" 25 I '$G(PSUCO) S PSUCOPAY="N" 26 Q 27 ; 28 EXP ;Expanded instructions: found in file (#52), multiple (#113), 29 ;sub-field (#.01) 30 ; 31 S PSUD1=0 32 F S PSUD1=$O(^TMP("PSOR",$J,PSURXIEN,"PI",PSUD1)) Q:PSUD1="" D 33 .I PSUD1=1 S PSUEXP=$E(^TMP("PSOR",$J,PSURXIEN,"PI",PSUD1,0),1,80) D 34 ..S PSUPI=$G(PSUEXP) 35 .I (PSUD1'=1),($L(PSUEXP)<80) D 36 ..S PSUEXP=$E(PSUEXP_" "_^TMP("PSOR",$J,PSURXIEN,"PI",PSUD1,0),1,80) 37 ..S PSUPI=$G(PSUEXP) 38 ; 39 Q 40 ; 41 DOSG ;Dosage data: found in file (#52), multiple (#113). There are 42 ;nine sub-fields to be pulled: #.01 through #8 43 ; 44 S PSUD1=0 45 F S PSUD1=$O(^TMP("PSOR",$J,PSURXIEN,"MI",PSUD1)) Q:PSUD1="" D 46 .I PSUD1'=1 S PSUMDFLG="M" ;Multidose flag 47 .I PSUD1=1 D ;Single dose/first Multidose data 48 ..S PSUAM=^TMP("PSOR",$J,PSURXIEN,"MI",PSUD1,0) 49 ..S PSUDSG=$P(PSUAM,U,1) ;Dosage Ordered 50 ..S PSUDISPU=$P(PSUAM,U,2) ;Dispense Units per Dose 51 ..S PSUNITS=$P($P(PSUAM,U,3),";",2) ;Units 52 ..S PSUNOUN=$P(PSUAM,U,4) ;Noun 53 ..S PSUDUR=$P(PSUAM,U,5) ;Duration 54 ..S PSUCONJ=$P(PSUAM,U,6) ;Conjunction 55 ..S PSUROUT=$P($P(PSUAM,U,7),";",2) ;Route 56 ..S PSUSCHED=$P(PSUAM,U,8) ;Schedule 57 ..S PSUVERB=$P(PSUAM,U,9) ;Verb 58 ; 59 Q 60 ; 61 MULTI ;Set variables for Multidose Medication Instructions 62 ;Called from PSUOP3 63 ; 64 S (PSUDSGMD,PSUDSPMD,PSUNITMD,PSUNMD)="" 65 S (PSURTMD,PSUSCHMD,PSUVRBMD)="" 66 ; 67 S PSUDSGMD=$P(PSUAMMD,U,1) ;Dosage Ordered 68 S PSUDSPMD=$P(PSUAMMD,U,2) ;Dispense Units per Dose 69 S PSUNITMD=$P($P(PSUAMMD,U,3),";",2) ;Units 70 S PSUNMD=$P(PSUAMMD,U,4) ;Noun 71 S PSUDURMD=$P(PSUAMMD,U,5) ;Duration 72 S PSUCONMD=$P(PSUAMMD,U,6) ;Conjunction 73 S PSURTMD=$P($P(PSUAMMD,U,7),";",2) ;Route 74 S PSUSCHMD=$P(PSUAMMD,U,8) ;Schedule 75 S PSUVRBMD=$P(PSUAMMD,U,9) ;Verb 76 ; 77 Q 1 PSUOPAM ;BIR/DAM - PSU PBM Outpatient AMIS Pharmacy Data Collection; March 2004 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005 3 ; 4 ;DBIA's 5 ;Reference to File (#52) supported by DBIA 1878 6 ; 7 EN ;entry point to gather additional AMIS data. Called from PSUOP2 8 ; 9 K PSUAM ;Array to hold single dose Medication Instructions 10 K PSUAMMD ;Array to hold multidose medication instructions 11 K PSUMDFLG ;Multidose flag 12 S (PSUPI,PSUCO,PSUEXP,PSUAM,PSUDSG,PSUDIPU,PSUNITS,PSUNOUN)="" 13 S (PSUDUR,PSUCONJ,PSUROUT,PSUSCHED,PSUVERB)="" 14 D CO 15 D EXP 16 D DOSG 17 Q 18 ; 19 ; 20 CO ;Copay status: found in file (#52), field (#105) 21 ; 22 S PSUCO=$P($G(^TMP("PSOR",$J,PSURXIEN,"IB",0)),U,1) 23 I $G(PSUCO) S PSUCOPAY="Y" 24 I '$G(PSUCO) S PSUCOPAY="N" 25 Q 26 ; 27 EXP ;Expanded instructions: found in file (#52), multiple (#113), 28 ;sub-field (#.01) 29 ; 30 S PSUD1=0 31 F S PSUD1=$O(^TMP("PSOR",$J,PSURXIEN,"PI",PSUD1)) Q:PSUD1="" D 32 .I PSUD1=1 S PSUEXP=$E(^TMP("PSOR",$J,PSURXIEN,"PI",PSUD1,0),1,80) D 33 ..S PSUPI=$G(PSUEXP) 34 .I (PSUD1'=1),($L(PSUEXP)<80) D 35 ..S PSUEXP=$E(PSUEXP_" "_^TMP("PSOR",$J,PSURXIEN,"PI",PSUD1,0),1,80) 36 ..S PSUPI=$G(PSUEXP) 37 ; 38 Q 39 ; 40 DOSG ;Dosage data: found in file (#52), multiple (#113). There are 41 ;nine sub-fields to be pulled: #.01 through #8 42 ; 43 S PSUD1=0 44 F S PSUD1=$O(^TMP("PSOR",$J,PSURXIEN,"MI",PSUD1)) Q:PSUD1="" D 45 .I PSUD1'=1 S PSUMDFLG="M" ;Multidose flag 46 .I PSUD1=1 D ;Single dose/first Multidose data 47 ..S PSUAM=^TMP("PSOR",$J,PSURXIEN,"MI",PSUD1,0) 48 ..S PSUDSG=$P(PSUAM,U,1) ;Dosage Ordered 49 ..S PSUDISPU=$P(PSUAM,U,2) ;Dispense Units per Dose 50 ..S PSUNITS=$P($P(PSUAM,U,3),";",2) ;Units 51 ..S PSUNOUN=$P(PSUAM,U,4) ;Noun 52 ..S PSUDUR=$P(PSUAM,U,5) ;Duration 53 ..S PSUCONJ=$P(PSUAM,U,6) ;Conjunction 54 ..S PSUROUT=$P($P(PSUAM,U,7),";",2) ;Route 55 ..S PSUSCHED=$P(PSUAM,U,8) ;Schedule 56 ..S PSUVERB=$P(PSUAM,U,9) ;Verb 57 ; 58 Q 59 ; 60 MULTI ;Set variables for Multidose Medication Instructions 61 ;Called from PSUOP3 62 ; 63 S (PSUDSGMD,PSUDSPMD,PSUNITMD,PSUNMD)="" 64 S (PSURTMD,PSUSCHMD,PSUVRBMD)="" 65 ; 66 S PSUDSGMD=$P(PSUAMMD,U,1) ;Dosage Ordered 67 S PSUDSPMD=$P(PSUAMMD,U,2) ;Dispense Units per Dose 68 S PSUNITMD=$P($P(PSUAMMD,U,3),";",2) ;Units 69 S PSUNMD=$P(PSUAMMD,U,4) ;Noun 70 S PSUDURMD=$P(PSUAMMD,U,5) ;Duration 71 S PSUCONMD=$P(PSUAMMD,U,6) ;Conjunction 72 S PSURTMD=$P($P(PSUAMMD,U,7),";",2) ;Route 73 S PSUSCHMD=$P(PSUAMMD,U,8) ;Schedule 74 S PSUVRBMD=$P(PSUAMMD,U,9) ;Verb 75 ; 76 Q -
WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUPR2.m
r613 r623 1 PSUPR2 ;BIR/PDW - Procurement extract from file 58.811 ; 4/1/08 4:09pm 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**13**;MARCH, 2005;Build 3 3 ;DBIAs 4 ; Reference to file #58.811 supported by DBIA 2521 5 ; Reference to file #51.5 supported by DBIA 1931 6 ; Reference to file #50 supported by DBIA 221 7 ; Reference to file #58.8 supported by DBIA 2519 8 ; Reference to file #42 supported by DBIA 2440 9 ; Reference to file #40.8 supported by DBIA 2438 10 ; Reference to file #59.5 supported by DBIA 2499 11 ; Reference to file #59 supported by DBIA 2510 12 ; 13 EN ; 14 S PSUEND=PSUEDT 15 S PSUEDT=PSUEDT\1+.24 16 S:'$D(PSUPRJOB) PSUPRJOB=$J 17 S:'$D(PSUPRSUB) PSUPRSUB="PSUPR_"_$J 18 I '$D(^XTMP(PSUPRSUB)) D 19 . S ^XTMP(PSUPRSUB,"RECORDS",0)="" 20 . S X1=DT,X2=6 D C^%DTC 21 . S ^XTMP(PSUPRSUB,0)=X_"^"_DT_"^ PBMS Procurement Extraction" 22 ; 23 S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB 24 D MAP 25 ; 26 ; check for Drug Accountability 27 S X=$$VERSION^XPDUTL("DRUG ACCOUNTABILITY") 28 I 'X Q ; not installed 29 ; 30 S X1=PSUSDT,X2=-45 ;backup by 45 days per revision 31 D C^%DTC 32 S PSUDT=X 33 ; loop thru invoice date field xref 34 F S PSUDT=$O(^PSD(58.811,"ADATE",PSUDT)) Q:PSUDT>PSUEDT Q:PSUDT'>0 D 35 . S PSUORDA=0 F S PSUORDA=$O(^PSD(58.811,"ADATE",PSUDT,PSUORDA)) Q:PSUORDA'>0 D 36 .. S PSUINVDA=0 F S PSUINVDA=$O(^PSD(58.811,"ADATE",PSUDT,PSUORDA,PSUINVDA)) Q:PSUINVDA'>0 D INVOICE 37 Q 38 ; 39 INVOICE ;EP process an invoice within an order 40 N PSUSTAT 41 S PSUSTAT=$$VALI^PSUTL(58.8112,"PSUORDA,PSUINVDA",2) 42 I PSUSTAT'="C" Q ; 3.2.6.1 43 N PSUORD 44 D GETS^PSUTL(58.811,PSUORDA,".01;1","PSUORD") 45 ; 46 S PSUINV="" 47 N PSURDT,PSUIVNUM 48 D GETS^PSUTL(58.8112,"PSUORDA,PSUINVDA",".01;1;2;3;4;7;8;13","PSUINV","I") 49 D MOVEI^PSUTL("PSUINV") 50 S PSURDT=PSUINV(8) 51 S PSUIVNUM=PSUINV(.01) 52 ; 53 I $G(PSUINV(4)) D DIV 54 I $L(PSUDIV) S PSUDIVI="" 55 E S PSUDIV=PSUSNDR,PSUDIVI="H" 56 ; 57 ; 58 K ^TMP($J,"PSUMIT") ; array for multiple items 59 D GETM^PSUTL(58.8112,"PSUORDA,PSUINVDA","5*^1;2;3;4;7;13;14;15","^TMP($J,""PSUMIT"")","I") 60 I '$D(^TMP($J,"PSUMIT")) Q ; 61 D MOVEMI^PSUTL("^TMP($J,""PSUMIT"")") 62 ; 63 S PSUITDA=0 F S PSUITDA=$O(^TMP($J,"PSUMIT",PSUITDA)) Q:PSUITDA'>0 D ITEM 64 Q 65 ITEM ;EP process one item within the invoice 66 N PSUIT ; array for one item 67 M PSUIT=^TMP($J,"PSUMIT",PSUITDA) 68 ; 69 I (PSUIT(7)<PSUSDT) Q 70 I (PSUIT(7)>PSUEDT) Q 71 ; pull adjustments 3.2.6.2.8 72 N PSUMADJ 73 D GETM^PSUTL(58.81125,"PSUORDA,PSUINVDA,PSUITDA","9*^.01;5","PSUMADJ","I") 74 I $D(PSUMADJ) D MOVEMI^PSUTL("PSUMADJ") 75 ; 76 ; 77 ; Review/Process Adjustments 78 I $D(PSUMADJ) S PSUADJDA=0 F S PSUADJDA=$O(PSUMADJ(PSUADJDA)) Q:PSUADJDA'>0 D 79 . N PSUADJ 80 . M PSUADJ=PSUMADJ(PSUADJDA) 81 . ; 82 . I PSUADJ(.01)="D" S PSUIT(1)=PSUADJ(5) ; 3.2.6.2.8 Drug or Supply 83 . I PSUADJ(.01)="O" S PSUIT(3)=PSUADJ(5) ; 3.2.6.2.11 OrderUnits 84 . I PSUADJ(.01)="P" S PSUIT(4)=PSUADJ(5) ; 3.2.6.2.12 Price 85 . I PSUADJ(.01)="Q" S PSUIT(2)=PSUIT(2)+PSUADJ(5) ; 3.2.6.2.10 Quantity 86 . Q 87 ; 88 I 'PSUIT(2) Q ; per Lina 10/7/98 if qty = 0 don't send record 89 ; work on the order unit PSUIT(3) 90 I '$D(PSUADJ),+PSUIT(3)=0 S PSUIT(3)="" ; per Lina 91 I PSUIT(3) S PSUIT(3)=$$VAL^PSUTL(51.5,PSUIT(3),.01) ; 3.2.6.2.11 92 ; 93 ; further process item fields 3.2.6.2.9 + 94 ; 95 ; look for/ construct Dispense Units per Order Unit 96 ; Store in PSUIT(9999) 3.2.6.2.13 97 ; Get Related Drug Fields 3.2.6.2.9 98 ; 99 N PSUDRUG 100 S PSUDRDA=0 101 ; if PSUIT(1) is a supply item the following will not be computed 102 I PSUIT(1)=+PSUIT(1) D 103 . S PSUDRDA=PSUIT(1) 104 . ;S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB 105 . D GETS^PSUTL(50,PSUDRDA,".01;2;13;25;14.5;21;31","PSUDRUG","I") 106 . D MOVEI^PSUTL("PSUDRUG") 107 . S PSUIT(1)=PSUDRUG(.01) ; Generic Name 108 . S:PSUDRUG(21)="" PSUDRUG(21)="Unknown VA Product Name" 109 . S:PSUDRUG(31)="" PSUDRUG(31)="No NDC" 110 ; further process fields 111 ; fill in drug fields for supply items 112 I 'PSUDRDA D 113 . S PSUDRUG(.01)="Unknown Generic Name" 114 . S PSUDRUG(21)="Unknown VA Product Name" 115 . S PSUDRUG(31)="No NDC" 116 ; 117 ; NDC 118 I PSUIT(13)="" S PSUIT(13)=$G(PSUDRUG(31)) S:PSUIT(13)="" PSUIT(13)="No NDC" 119 ; 120 ; dispense units per order unit 3.2.6.2.13 121 ; 122 S PSUIT(9999)=0 123 I $L(PSUIT(13)),$G(PSUDRDA) D 124 . S X=$O(^PSDRUG("C",PSUIT(13),PSUDRDA,"")) 125 . I X S PSUIT(9999)=$$VALI^PSUTL(50.1,"PSUDRDA,X","403") 126 ; 127 I '$D(PSUADJ),'PSUIT(9999) S PSUIT(9999)="" ; per Lina 128 ; 129 ;PSU*4*13 Comment out To prevent XINDEX from complaining about 130 ; ^PSUPR7 (CoreFLS remnance) 131 ;Create "RECORDS" global for CoreFLS data 132 ;I $D(PSUFLSFG) S PSUA="" D 133 ;.F S PSUA=$O(^XTMP(PSUPRSUB,"PSUFLS",PSUA)) Q:PSUA="" D SIMPL^PSUPR7 134 ; 135 ; Construct record and store into ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,LC) 136 S PSUR=$$RECORD() 137 ; Store Records by Division 138 S PSULC=+$O(^XTMP(PSUPRSUB,"RECORDS",PSUDIV,""),-1) 139 S PSULC=PSULC+1 140 S ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,PSULC)=PSUR 141 Q 142 ; 143 RECORD() ;EP Assemble record 144 N PSUR 145 S PSUR(2)=$G(PSUDIV) 146 S PSUR(3)=$G(PSUDIVI) 147 S PSUR(4)=PSUIT(7)\1 ; 3.2.6.2.2 148 S PSUR(5)=$G(PSUDRUG(21)) ; 3.2.6.2.9 149 S PSUR(6)=$G(PSUDRUG(2)) ; "" 150 S PSUR(7)=PSUIT(1) ; 3.2.6.2.8 151 S PSUR(9)=PSUIT(13) ; 3.2.6.2.9 152 S PSUR(10)=PSUIT(14) ; "" 153 S PSUR(11)=PSUIT(15) ; "" 154 S PSUR(12)=$G(PSUDRUG(14.5)) ; "" 155 S PSUR(13)=PSUIT(3) ; 3.2.6.2.11 156 S PSUR(16)=PSUIT(9999) ; 3.2.6.2.13 157 S PSUR(17)=PSUIT(2) ; 3.2.6.2.10 158 S PSUR(18)=PSUIT(4) ; 3.2.6.2.12 159 S PSUR(19)=PSUR(17)*PSUR(18) ; 3.2.6.2.14 160 S PSUR(20)=PSUORD(1) ; 3.2.6.2.5 161 S PSUR(21)=PSUINV(.01) ; 3.2.6.2.6 162 S PSUR(22)="" 163 S PSUR="" 164 S I=0 F S I=$O(PSUR(I)) Q:I'>0 S PSUR(I)=$TR(PSUR(I),"^","'") 165 S I=0 F S I=$O(PSUR(I)) Q:I'>0 S $P(PSUR,U,I)=PSUR(I) 166 S PSUR=PSUR_U 167 Q PSUR 168 ; 169 DIV ;Find division or outpatient site 170 ; 171 S PSUDIV="" 172 N MAPLOCI 173 D GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOCI","I") 174 D MOVEMI^PSUTL("MAPLOCI") 175 ; 176 I $G(MAPLOCI(PSUINV(4),.01)) D 177 .S X=$G(MAPLOCI(PSUINV(4),.02)) I X S PSUDIV=$$VALI^PSUTL(40.8,X,1) 178 .S X=$G(MAPLOCI(PSUINV(4),.03)) I X S PSUDIV=$$VALI^PSUTL(59,X,.06) 179 I '$G(MAPLOCI(PSUINV(4),.01)) D 180 .S PSUDIV=PSUSNDR 181 .S PSUDIVI="H" 182 Q 183 ; 184 ; 185 MAP ;Find out whether a Narcotics Area of Use (NAOU) or a DA Pharmacy 186 ;Location is mapped to a division or outpatient site. If it is not 187 ;mapped, store the NAME and INACTIVATION DAT (if applicable) in a 188 ;global to be mailed to the user. 189 ; 190 K NAOU,DAPH 191 K MAPLOCI,MAPLOC 192 S PSUNAM=0 ;This is the name of the NAOU or DA PHARMACY 193 ; 194 F S PSUNAM=$O(^PSD(58.8,"B",PSUNAM)) Q:PSUNAM="" D 195 .S IEN=0 196 .F S IEN=$O(^PSD(58.8,"B",PSUNAM,IEN)) Q:IEN="" D 197 ..D GETS^PSUTL(58.8,IEN,".01;1;4","NAOU(IEN)") 198 ..I NAOU(IEN,1)="PRIMARY" M DAPH(IEN)=NAOU(IEN) K NAOU(IEN) 199 ..D MAP1 200 ; 201 Q 202 ; 203 MAP1 ;MAP continued. This subroutine takes the IEN from file 58.8 and looks 204 ;to see if it is in file 59.7, field 90.02 or 90.03. 205 ; 206 ;If it is in 90.02, and field 4 from 58.8 is NOT "P", and there is 207 ;no value in subfield .02 or .03, then an NAOU has not been mapped. 208 ; 209 ;If it is in 90.03, and field 4 from 58.8 IS a "P", and there is 210 ;no value in subfield .02 or .03, then a DA PHARMACY location has not 211 ;been mapped. 212 ; 213 ;Keep only the entries that are NOT mapped 214 ; 215 N PSUDA 216 ; 217 ;Look for unmapped NAOU's 218 ;I $G(NAOU(IEN),1) D 219 I $G(^PS(59.7,1,90.02,IEN,0)) D 220 .D GETM^PSUTL(59.7,1,"90.02*^.01;.02;.03","MAPLOCI") 221 .S PSUDA=0 222 .F S PSUDA=$O(MAPLOCI(PSUDA)) Q:PSUDA="" D 223 ..I MAPLOCI(PSUDA,.02)'="" K NAOU(PSUDA) 224 ..I MAPLOCI(PSUDA,.03)'="" K NAOU(PSUDA) 225 M ^XTMP(PSUARSUB,"NAOU")=NAOU ;only unmapped NAOU locations. 226 ; 227 ; 228 ;Look for unmapped DA PHARM 229 I $G(^PS(59.7,1,90.03,IEN,0)) D 230 .D GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOC") 231 .S PSUDA=0 232 .F S PSUDA=$O(MAPLOC(PSUDA)) Q:PSUDA="" D 233 ..;PSU*4*13 Correct Problm DA Pharm Report 234 ..I $G(MAPLOC(PSUDA,.02))'="" K DAPH(PSUDA) 235 ..I $G(MAPLOC(PSUDA,.03))'="" K DAPH(PSUDA) 236 M ^XTMP(PSUARSUB,"DAPH")=DAPH ;only unmapped DA PHARM locations. 237 Q 238 ; 239 WRD() ;EP Process for ward; 240 N PSUWD,PSUWDDA,PSUDIV 241 S PSUDIV="" 242 D GETM^PSUTL(58.8,PSULOC,"21*^.01","PSUWD","I") 243 D MOVEMI^PSUTL("PSUWD") 244 ; loop ward pointers 245 S PSUWDDA=0 246 F S PSUWDDA=$O(PSUWD(PSUWDDA)) Q:PSUWDDA'>0 D Q:$L(PSUDIV) 247 . S X=$$VALI^PSUTL(42,PSUWDDA,.015) 248 . Q:'X 249 . S X=$$VALI^PSUTL(40.8,X,1) 250 . I $L(X) S PSUDIV=X 251 ; return value of PSUDIV "" or = facility number 252 Q PSUDIV 253 ; 254 INP() ;EP Process for Inpatient 255 ; within package call to AR/WS that pulls/builds Inpatient AOU Site 256 ; uses IEN Value to AOU STATs file 58.5 257 N PSUARSUB,PSUARJOB 258 S PSULOCA=$$VALI^PSUTL(58.8,PSULOC,2) 259 N PSULOC 260 S PSUARSUB=PSUPRSUB,PSUARJOB=PSUPRJOB 261 S X=$$DIV^PSUAR1(PSULOCA,PSUDT) ;returns "NULL" if none found 262 S:X="NULL" X="" 263 Q X 264 ; 265 IV() ;EP Process,PSUIVDA for IV 266 ; PSULOC IEN pharmacy location in file 58.8 (DRUG ACCOUNTABILITY) 267 N PSUIV,PSUDIV 268 S PSUDIV="" 269 D GETM^PSUTL(58.8,PSULOC,"31*^.01","PSUIV","I") 270 D MOVEMI^PSUTL("PSUIV") 271 S PSUIVDA=0 272 F S PSUIVDA=$O(PSUIV(PSUIVDA)) Q:PSUIVDA'>0 D Q:$L(PSUDIV) 273 . S X=$$VALI^PSUTL(59.5,PSUIVDA,.02) 274 . I X S X=$$VALI^PSUTL(40.8,X,1) 275 . I $L(X) S PSUDIV=X 276 ; 277 Q PSUDIV 278 ; 279 OUT() ;EP Process for Outpatient 280 S X=$$VALI^PSUTL(58.8,PSULOC,20) 281 I X S X=$$VALI^PSUTL(59,X,.06) 282 Q X 283 ; 1 PSUPR2 ;BIR/PDW - Procurement extract from file 58.811 ;20 AUG 1999 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005 3 ;DBIAs 4 ; Reference to file #58.811 supported by DBIA 2521 5 ; Reference to file #51.5 supported by DBIA 1931 6 ; Reference to file #50 supported by DBIA 221 7 ; Reference to file #58.8 supported by DBIA 2519 8 ; Reference to file #42 supported by DBIA 2440 9 ; Reference to file #40.8 supported by DBIA 2438 10 ; Reference to file #59.5 supported by DBIA 2499 11 ; Reference to file #59 supported by DBIA 2510 12 ; 13 EN ; 14 S PSUEND=PSUEDT 15 S PSUEDT=PSUEDT\1+.24 16 S:'$D(PSUPRJOB) PSUPRJOB=$J 17 S:'$D(PSUPRSUB) PSUPRSUB="PSUPR_"_$J 18 I '$D(^XTMP(PSUPRSUB)) D 19 . S ^XTMP(PSUPRSUB,"RECORDS",0)="" 20 . S X1=DT,X2=6 D C^%DTC 21 . S ^XTMP(PSUPRSUB,0)=X_"^"_DT_"^ PBMS Procurement Extraction" 22 ; 23 S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB 24 D MAP 25 ; 26 ; check for Drug Accountability 27 S X=$$VERSION^XPDUTL("DRUG ACCOUNTABILITY") 28 I 'X Q ; not installed 29 ; 30 S X1=PSUSDT,X2=-45 ;backup by 45 days per revision 31 D C^%DTC 32 S PSUDT=X 33 ; loop thru invoice date field xref 34 F S PSUDT=$O(^PSD(58.811,"ADATE",PSUDT)) Q:PSUDT>PSUEDT Q:PSUDT'>0 D 35 . S PSUORDA=0 F S PSUORDA=$O(^PSD(58.811,"ADATE",PSUDT,PSUORDA)) Q:PSUORDA'>0 D 36 .. S PSUINVDA=0 F S PSUINVDA=$O(^PSD(58.811,"ADATE",PSUDT,PSUORDA,PSUINVDA)) Q:PSUINVDA'>0 D INVOICE 37 Q 38 ; 39 INVOICE ;EP process an invoice within an order 40 N PSUSTAT 41 S PSUSTAT=$$VALI^PSUTL(58.8112,"PSUORDA,PSUINVDA",2) 42 I PSUSTAT'="C" Q ; 3.2.6.1 43 N PSUORD 44 D GETS^PSUTL(58.811,PSUORDA,".01;1","PSUORD") 45 ; 46 S PSUINV="" 47 N PSURDT,PSUIVNUM 48 D GETS^PSUTL(58.8112,"PSUORDA,PSUINVDA",".01;1;2;3;4;7;8;13","PSUINV","I") 49 D MOVEI^PSUTL("PSUINV") 50 S PSURDT=PSUINV(8) 51 S PSUIVNUM=PSUINV(.01) 52 ; 53 I $G(PSUINV(4)) D DIV 54 I $L(PSUDIV) S PSUDIVI="" 55 E S PSUDIV=PSUSNDR,PSUDIVI="H" 56 ; 57 ; 58 K ^TMP($J,"PSUMIT") ; array for multiple items 59 D GETM^PSUTL(58.8112,"PSUORDA,PSUINVDA","5*^1;2;3;4;7;13;14;15","^TMP($J,""PSUMIT"")","I") 60 I '$D(^TMP($J,"PSUMIT")) Q ; 61 D MOVEMI^PSUTL("^TMP($J,""PSUMIT"")") 62 ; 63 S PSUITDA=0 F S PSUITDA=$O(^TMP($J,"PSUMIT",PSUITDA)) Q:PSUITDA'>0 D ITEM 64 Q 65 ITEM ;EP process one item within the invoice 66 N PSUIT ; array for one item 67 M PSUIT=^TMP($J,"PSUMIT",PSUITDA) 68 ; 69 I (PSUIT(7)<PSUSDT) Q 70 I (PSUIT(7)>PSUEDT) Q 71 ; pull adjustments 3.2.6.2.8 72 N PSUMADJ 73 D GETM^PSUTL(58.81125,"PSUORDA,PSUINVDA,PSUITDA","9*^.01;5","PSUMADJ","I") 74 I $D(PSUMADJ) D MOVEMI^PSUTL("PSUMADJ") 75 ; 76 ; 77 ; Review/Process Adjustments 78 I $D(PSUMADJ) S PSUADJDA=0 F S PSUADJDA=$O(PSUMADJ(PSUADJDA)) Q:PSUADJDA'>0 D 79 . N PSUADJ 80 . M PSUADJ=PSUMADJ(PSUADJDA) 81 . ; 82 . I PSUADJ(.01)="D" S PSUIT(1)=PSUADJ(5) ; 3.2.6.2.8 Drug or Supply 83 . I PSUADJ(.01)="O" S PSUIT(3)=PSUADJ(5) ; 3.2.6.2.11 OrderUnits 84 . I PSUADJ(.01)="P" S PSUIT(4)=PSUADJ(5) ; 3.2.6.2.12 Price 85 . I PSUADJ(.01)="Q" S PSUIT(2)=PSUIT(2)+PSUADJ(5) ; 3.2.6.2.10 Quantity 86 . Q 87 ; 88 I 'PSUIT(2) Q ; per Lina 10/7/98 if qty = 0 don't send record 89 ; work on the order unit PSUIT(3) 90 I '$D(PSUADJ),+PSUIT(3)=0 S PSUIT(3)="" ; per Lina 91 I PSUIT(3) S PSUIT(3)=$$VAL^PSUTL(51.5,PSUIT(3),.01) ; 3.2.6.2.11 92 ; 93 ; further process item fields 3.2.6.2.9 + 94 ; 95 ; look for/ construct Dispense Units per Order Unit 96 ; Store in PSUIT(9999) 3.2.6.2.13 97 ; Get Related Drug Fields 3.2.6.2.9 98 ; 99 N PSUDRUG 100 S PSUDRDA=0 101 ; if PSUIT(1) is a supply item the following will not be computed 102 I PSUIT(1)=+PSUIT(1) D 103 . S PSUDRDA=PSUIT(1) 104 . ;S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB 105 . D GETS^PSUTL(50,PSUDRDA,".01;2;13;25;14.5;21;31","PSUDRUG","I") 106 . D MOVEI^PSUTL("PSUDRUG") 107 . S PSUIT(1)=PSUDRUG(.01) ; Generic Name 108 . S:PSUDRUG(21)="" PSUDRUG(21)="Unknown VA Product Name" 109 . S:PSUDRUG(31)="" PSUDRUG(31)="No NDC" 110 ; further process fields 111 ; fill in drug fields for supply items 112 I 'PSUDRDA D 113 . S PSUDRUG(.01)="Unknown Generic Name" 114 . S PSUDRUG(21)="Unknown VA Product Name" 115 . S PSUDRUG(31)="No NDC" 116 ; 117 ; NDC 118 I PSUIT(13)="" S PSUIT(13)=$G(PSUDRUG(31)) S:PSUIT(13)="" PSUIT(13)="No NDC" 119 ; 120 ; dispense units per order unit 3.2.6.2.13 121 ; 122 S PSUIT(9999)=0 123 I $L(PSUIT(13)),$G(PSUDRDA) D 124 . S X=$O(^PSDRUG("C",PSUIT(13),PSUDRDA,"")) 125 . I X S PSUIT(9999)=$$VALI^PSUTL(50.1,"PSUDRDA,X","403") 126 ; 127 I '$D(PSUADJ),'PSUIT(9999) S PSUIT(9999)="" ; per Lina 128 ; 129 ;Create "RECORDS" global for CoreFLS data 130 I $D(PSUFLSFG) S PSUA="" D 131 .F S PSUA=$O(^XTMP(PSUPRSUB,"PSUFLS",PSUA)) Q:PSUA="" D SIMPL^PSUPR7 132 ; 133 ; Construct record and store into ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,LC) 134 S PSUR=$$RECORD() 135 ; Store Records by Division 136 S PSULC=+$O(^XTMP(PSUPRSUB,"RECORDS",PSUDIV,""),-1) 137 S PSULC=PSULC+1 138 S ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,PSULC)=PSUR 139 Q 140 ; 141 RECORD() ;EP Assemble record 142 N PSUR 143 S PSUR(2)=$G(PSUDIV) 144 S PSUR(3)=$G(PSUDIVI) 145 S PSUR(4)=PSUIT(7)\1 ; 3.2.6.2.2 146 S PSUR(5)=$G(PSUDRUG(21)) ; 3.2.6.2.9 147 S PSUR(6)=$G(PSUDRUG(2)) ; "" 148 S PSUR(7)=PSUIT(1) ; 3.2.6.2.8 149 S PSUR(9)=PSUIT(13) ; 3.2.6.2.9 150 S PSUR(10)=PSUIT(14) ; "" 151 S PSUR(11)=PSUIT(15) ; "" 152 S PSUR(12)=$G(PSUDRUG(14.5)) ; "" 153 S PSUR(13)=PSUIT(3) ; 3.2.6.2.11 154 S PSUR(16)=PSUIT(9999) ; 3.2.6.2.13 155 S PSUR(17)=PSUIT(2) ; 3.2.6.2.10 156 S PSUR(18)=PSUIT(4) ; 3.2.6.2.12 157 S PSUR(19)=PSUR(17)*PSUR(18) ; 3.2.6.2.14 158 S PSUR(20)=PSUORD(1) ; 3.2.6.2.5 159 S PSUR(21)=PSUINV(.01) ; 3.2.6.2.6 160 S PSUR(22)="" 161 S PSUR="" 162 S I=0 F S I=$O(PSUR(I)) Q:I'>0 S PSUR(I)=$TR(PSUR(I),"^","'") 163 S I=0 F S I=$O(PSUR(I)) Q:I'>0 S $P(PSUR,U,I)=PSUR(I) 164 S PSUR=PSUR_U 165 Q PSUR 166 ; 167 DIV ;Find division or outpatient site 168 ; 169 S PSUDIV="" 170 N MAPLOCI 171 D GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOCI","I") 172 D MOVEMI^PSUTL("MAPLOCI") 173 ; 174 I $G(MAPLOCI(PSUINV(4),.01)) D 175 .S X=$G(MAPLOCI(PSUINV(4),.02)) I X S PSUDIV=$$VALI^PSUTL(40.8,X,1) 176 .S X=$G(MAPLOCI(PSUINV(4),.03)) I X S PSUDIV=$$VALI^PSUTL(59,X,.06) 177 I '$G(MAPLOCI(PSUINV(4),.01)) D 178 .S PSUDIV=PSUSNDR 179 .S PSUDIVI="H" 180 Q 181 ; 182 ; 183 MAP ;Find out whether a Narcotics Area of Use (NAOU) or a DA Pharmacy 184 ;Location is mapped to a division or outpatient site. If it is not 185 ;mapped, store the NAME and INACTIVATION DAT (if applicable) in a 186 ;global to be mailed to the user. 187 ; 188 K NAOU,DAPH 189 K MAPLOCI,MAPLOC 190 S PSUNAM=0 ;This is the name of the NAOU or DA PHARMACY 191 ; 192 F S PSUNAM=$O(^PSD(58.8,"B",PSUNAM)) Q:PSUNAM="" D 193 .S IEN=0 194 .F S IEN=$O(^PSD(58.8,"B",PSUNAM,IEN)) Q:IEN="" D 195 ..D GETS^PSUTL(58.8,IEN,".01;1;4","NAOU(IEN)") 196 ..I NAOU(IEN,1)="PRIMARY" M DAPH(IEN)=NAOU(IEN) K NAOU(IEN) 197 ..D MAP1 198 ; 199 Q 200 ; 201 MAP1 ;MAP continued. This subroutine takes the IEN from file 58.8 and looks 202 ;to see if it is in file 59.7, field 90.02 or 90.03. 203 ; 204 ;If it is in 90.02, and field 4 from 58.8 is NOT "P", and there is 205 ;no value in subfield .02 or .03, then an NAOU has not been mapped. 206 ; 207 ;If it is in 90.03, and field 4 from 58.8 IS a "P", and there is 208 ;no value in subfield .02 or .03, then a DA PHARMACY location has not 209 ;been mapped. 210 ; 211 ;Keep only the entries that are NOT mapped 212 ; 213 N PSUDA 214 ; 215 ;Look for unmapped NAOU's 216 ;I $G(NAOU(IEN),1) D 217 I $G(^PS(59.7,1,90.02,IEN,0)) D 218 .D GETM^PSUTL(59.7,1,"90.02*^.01;.02;.03","MAPLOCI") 219 .S PSUDA=0 220 .F S PSUDA=$O(MAPLOCI(PSUDA)) Q:PSUDA="" D 221 ..I MAPLOCI(PSUDA,.02)'="" K NAOU(PSUDA) 222 ..I MAPLOCI(PSUDA,.03)'="" K NAOU(PSUDA) 223 M ^XTMP(PSUARSUB,"NAOU")=NAOU ;only unmapped NAOU locations. 224 ; 225 ; 226 ;Look for unmapped DA PHARM 227 I $G(^PS(59.7,1,90.03,IEN,0)) D 228 .D GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOC") 229 .S PSUDA=0 230 .F S PSUDA=$O(MAPLOC(PSUDA)) Q:PSUDA="" D 231 ..I $G(MAPLOC(PSUDA,.02))'="" K NAOU(PSUDA) 232 ..I $G(MAPLOC(PSUDA,.03))'="" K NAOU(PSUDA) 233 M ^XTMP(PSUARSUB,"DAPH")=DAPH ;only unmapped DA PHARM locations. 234 Q 235 ; 236 WRD() ;EP Process for ward; 237 N PSUWD,PSUWDDA,PSUDIV 238 S PSUDIV="" 239 D GETM^PSUTL(58.8,PSULOC,"21*^.01","PSUWD","I") 240 D MOVEMI^PSUTL("PSUWD") 241 ; loop ward pointers 242 S PSUWDDA=0 243 F S PSUWDDA=$O(PSUWD(PSUWDDA)) Q:PSUWDDA'>0 D Q:$L(PSUDIV) 244 . S X=$$VALI^PSUTL(42,PSUWDDA,.015) 245 . Q:'X 246 . S X=$$VALI^PSUTL(40.8,X,1) 247 . I $L(X) S PSUDIV=X 248 ; return value of PSUDIV "" or = facility number 249 Q PSUDIV 250 ; 251 INP() ;EP Process for Inpatient 252 ; within package call to AR/WS that pulls/builds Inpatient AOU Site 253 ; uses IEN Value to AOU STATs file 58.5 254 N PSUARSUB,PSUARJOB 255 S PSULOCA=$$VALI^PSUTL(58.8,PSULOC,2) 256 N PSULOC 257 S PSUARSUB=PSUPRSUB,PSUARJOB=PSUPRJOB 258 S X=$$DIV^PSUAR1(PSULOCA,PSUDT) ;returns "NULL" if none found 259 S:X="NULL" X="" 260 Q X 261 ; 262 IV() ;EP Process,PSUIVDA for IV 263 ; PSULOC IEN pharmacy location in file 58.8 (DRUG ACCOUNTABILITY) 264 N PSUIV,PSUDIV 265 S PSUDIV="" 266 D GETM^PSUTL(58.8,PSULOC,"31*^.01","PSUIV","I") 267 D MOVEMI^PSUTL("PSUIV") 268 S PSUIVDA=0 269 F S PSUIVDA=$O(PSUIV(PSUIVDA)) Q:PSUIVDA'>0 D Q:$L(PSUDIV) 270 . S X=$$VALI^PSUTL(59.5,PSUIVDA,.02) 271 . I X S X=$$VALI^PSUTL(40.8,X,1) 272 . I $L(X) S PSUDIV=X 273 ; 274 Q PSUDIV 275 ; 276 OUT() ;EP Process for Outpatient 277 S X=$$VALI^PSUTL(58.8,PSULOC,20) 278 I X S X=$$VALI^PSUTL(59,X,.06) 279 Q X 280 ; -
WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSURT1.m
r613 r623 1 PSURT1 ;BIR/RDC - PATIENT DEMOGRAPHIC RETRANSMITION; APR 2, 2007 ; 4/2/07 11:01am2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19 3 4 5 6 7 8 EN 9 10 11 ; move call to CLEANUP^PSUHL to routine PSUCP (PSU*4*12) 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 MONTH 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 RANGE 58 59 60 BGNRNG 61 62 63 64 65 66 67 68 69 70 71 ENDRNG 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 PROCESS 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 1 PSURT1 ;BIR/RDC - PATIENT DEMOGRAPHIC RETRANSMITION; 31 MAR 2004 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005 3 ; 4 ; THIS PROGRAM WILL ALLOW THE RETRANSMITION OF THE PATIENT 5 ; DEMOGRAPHIC DATA FOR THE PBM EXTRACT USING THE DATA 6 ; FROM ^PSUDEM (59.9) FOR RUN TIME OPTIMIZATION 7 ; 8 EN ; ENTRY POINT 9 NEW P,SDT,EDT,WHEN,NOGOOD,TMON,RMONTH,PMON,SMON,EMON,RTYPE,SRANGE,ERANGE 10 S P="" 11 D CLEANUP^PSUHL 12 S SDT=$O(^PSUDEM("B",P)) 13 I 'SDT W !,"NO DATA AVAILABLE - NOTIFY YOUR SUPERVISOR" Q 14 S EDT=$O(^PSUDEM("B",P),-1) 15 S Y=SDT X ^DD("DD") S START=Y 16 S Y=EDT-1 X ^DD("DD") S STOP=Y 17 W !,"This option will allow the retransmission of Patient Demographic and Outpatient Visit data stored in the PBM PATIENT DEMOGRAPHICS FILE. Statistical data starting from " 18 W START 19 W " through " 20 W STOP 21 W " is available for retransmission." 22 W ! 23 ; 24 ; let fileman get response 25 S DIR("A")="Is this a monthly report",DIR(0)="YO" 26 D ^DIR K DIR 27 ; 28 S NOGOOD=1 29 I Y=1 S NOGOOD=0 D MONTH 30 I Y=0 S NOGOOD=0 D RANGE 31 Q:NOGOOD 32 D PROCESS ; *** process the extract *** 33 Q 34 ; 35 MONTH ; *** allow only whole months to be processed *** 36 W ! 37 S TMON=$E(DT,4,5) 38 S DIR("A")="Select Month/Year",DIR(0)="F" D ^DIR 39 K DIR,DIR("A") 40 I $D(DIRUT) S NOGOOD=1 Q 41 S %DT="MP" D ^%DT K %DT 42 I Y=-1 W !!,"Invalid Month/Year. Please Reenter a month and year." G MONTH 43 S RMONTH=$$FMTE^XLFDT(Y) W " ("_RMONTH_")" 44 ; S %DT(0)=SDT,%DT="MP" 45 ; S X=Y 46 ; D ^%DT K %DT 47 I $E(Y,4,5)=TMON S Y=-1 48 I Y=-1 W !!,"Data for the entire month of "_RMONTH_" is not available. Please reenter a month/year." G MONTH 49 I Y>DT W !!,"You may not select a date from the future. Please reenter a month/year within the valid parameters." G MONTH 50 ; 51 S PSURMON=Y 52 S SMON=$E(PSURMON,1,5)_"00" 53 S EMON=$E(PSURMON,1,5)_"99" 54 S RTYPE="M" 55 Q 56 ; 57 RANGE ; *** process a range of dates from within file #59.9 *** 58 S %DT(0)=SDT 59 ; 60 BGNRNG ; 61 W ! 62 S %DT="PAE",%DT("A")="Select start date: " D ^%DT K %DT,%DT("A") 63 I X="^"!($G(DTOUT)) S NOGOOD=1 Q 64 I Y=-1 W !!,"Invalid date. Please reenter a start date." G BGNRNG 65 I Y=DT W !!,"Today is not a valid start date. Please reenter a start date." G BGNRNG 66 ; 67 I Y>DT W !!,"You may not select a date in the future. Please reenter a start date." G BGNRNG 68 ; 69 S SRANGE=Y ; * start with this date *** 70 ; 71 ENDRNG ; 72 W ! 73 S %DT="PAE",%DT("A")="Select stop date: " D ^%DT K %DT,%DT("A") 74 I X="^"!($G(DTOUT)) S NOGOOD=1 Q 75 I Y=-1 W !!,"Invalid date. Please reenter a stop date." G ENDRNG 76 I Y=DT W !!,"Statistical data has not been compiled for current date. Please reenter a stop date." G ENDRNG 77 ; 78 I Y<SRANGE W !!,"You need to select a stop date greater than your start date. Please reenter your start/stop dates." G BGNRNG 79 ; 80 I Y>DT W !!,"You may not select a date in the future. Please reenter a stop date." G ENDRNG 81 ; 82 S ERANGE=Y ; * end at this date *** 83 ; 84 S RTYPE="R" 85 K %DT(0) 86 ; 87 Q 88 PROCESS ; 89 I RTYPE="R" S (START,PSUSRNG)=SRANGE,(LAST,PSUERNG)=ERANGE 90 I RTYPE="M" S START=SMON,LAST=EMON 91 ; 92 S PSUSMRY=0 93 W !! 94 S DIR("A")="Do you want a copy of this report sent to you in a MailMan message?" 95 S DIR(0)="YO" 96 S DIR("B")="NO" 97 D ^DIR K DIR,DIR(0) 98 I Y="^" Q 99 I Y=1 S PSUMME=1,PSUDUZ=DUZ 100 ; 101 I RTYPE="M" D 102 . W !! 103 . S DIR("A")="Send this to the PBM section for addition to the master file?" 104 . S DIR(0)="YO" 105 . S DIR("B")="NO" 106 . D ^DIR K DIR,DIR(0) 107 . I Y=1 S PSUMSTR=1 108 ; 109 I Y="^" Q 110 S PSUSTART=START,PSULAST=LAST 111 K %DT,PSUWHEN 112 D NOW^%DTC S %DT="REAX",%DT(0)="A",%DT("B")="NOW",%DT("A")="Queue to run at what time: " D ^%DT 113 S PSUWHEN=Y 114 S ZTRTN="EN^PSURT2",ZTIO="",ZTDESC="RETRASMISSION OF PT DEMOGRAPHICS",ZTDTH=PSUWHEN 115 S ZTSAVE("PSUSTART")="" 116 S ZTSAVE("PSULAST")="" 117 S ZTSAVE("PSUMME")="" 118 S ZTSAVE("PSUMSTR")="" 119 S ZTSAVE("PSURMON")="" 120 S ZTSAVE("PSUSRNG")="" 121 S ZTSAVE("PSUERNG")="" 122 S ZTSAVE("PSUDUZ")="" 123 S ZTSAVE("PSUSMRY")="" 124 ; 125 ; D ^PSURT2 126 ; Q 127 ; 128 D ^%ZTLOAD 129 Q 130 ; -
WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUSUM1.m
r613 r623 1 PSUSUM1 ;BIR/DAM - Summary Report for Provider Extract ; 2/23/07 2:18pm 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19 3 ; 4 ; No DBIA's required. 5 ; 6 EN ;EN CALLED FROM ^PSUDEM4 7 ; 8 D PULL^PSUCP 9 D DATE 10 D PRSUM^PSUDEM5 ;Mail message 11 Q 12 ; 13 DATE ;Convert dates to external format 14 ; 15 S %H=$E($H,1,5) ;today's date 16 D YX^%DTC 17 N PSUD S PSUD=Y 18 ; 19 S Y=PSUSDT ;Start date of extract 20 D DD^%DT 21 N PSUS S PSUS=Y 22 ; 23 S Y=PSUEDT ;End date of extract 24 D DD^%DT 25 N PSUE S PSUE=Y 26 ; 27 D SUMM 28 Q 29 ; 30 SUMM ;Compose summary mail message by placing all text into a 31 ;temporary global, designated ^XTMP("PSU_"_PSUJOB,"PSUSUM", 32 ; 33 ; 34 ;Report header 35 I '$D(^XTMP("PSU_"_PSUJOB,"PSUPROV")) D Q 36 .S ^XTMP("PSU_"_PSUJOB,"PSUSUM",1)="No data to report" 37 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",1)="Provider Summary Report "_PSUD 38 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",2)="" ;Blank line 39 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",3)=" "_PSUS_" through "_PSUE 40 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",4)="" 41 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUM",5),"-",80)="" ;Separator Bar 42 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUM",7),"-",80)="" 43 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",8)="" 44 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",9)="IEN Provider Name (SSN) Missing Data" 45 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUM",10),"-",80)="" 46 D PROV 47 ; 48 Q 49 ; 50 PROV ;Gather missing provider data for summary report 51 ; 52 N PSUSSN3,PSUMIS,PSUCL,PSUSS,PSUSP,PSUSUB,PSULN,PSUM 53 S PSUM=0 54 S PSULN=11 55 S PSUIP=0 56 F S PSUIP=$O(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)) Q:PSUIP="" Q:PSUIP["U" D 57 .I $P($G(^VA(200,PSUIP,"PS")),"^",6)=4 Q ; Exclude if the provider type is "FEE BASIS" (PSU*4*12) 58 .S PSUSSN3=$E($P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,3),6,9) 59 .I PSUSSN3="" S PSUSSN3="????",PSUMIS="SSN" D NAM ;No SSN 60 .S PSUCL=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,5) 61 .I PSUCL="" S PSUMIS="PROVIDER CLASS" D NAM ;No Class 62 .S PSUSS=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,6) 63 .I PSUSS="" S PSUMIS="SERVICE/SECTION" D NAM ;No Ser/Sec 64 .S PSUSP=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,7) 65 .I PSUSP="" S PSUMIS="SPECIALTY" D NAM ;No Spec 66 .Q:PSUSP["Intern" ;Omit interns from missing subspec. on report 67 .Q:PSUSP["Resident" ;Omit residents from missing subspc. on report 68 .S PSUSUB=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,8) 69 .I PSUSUB="" S PSUMIS="SUBSPECIALTY" D NAM ;No Subsp 70 Q 71 ; 72 NAM ;Get Provider name and create entry line in summary report 73 ; 74 N PSUNAM,PSUT1,PSUT2,PSUT3,PSUT4,S1,S2,S3 75 N PSUT5,PSUT6,PSUT7,PSUT8,PSUT9,PSUT10 76 ; 77 S PSUT4=" " 78 S PSUT1=11 79 S PSUT2=PSUT1-$L(PSUIP) 80 F S1=1:1:(PSUT2-1) S PSUT3(S1)=" " D 81 .S PSUT4=PSUT4_PSUT3(S1) ;First tab position 82 ; 83 S PSUNAM=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,9) 84 ; 85 S PSUT5=" " 86 S PSUT6=54 87 S PSUT7=(PSUT6-$L(PSUNAM)-7-$L(PSUT4)-$L(PSUIP)) 88 F S2=1:1:(PSUT7-1) S PSUT8(S2)=" " D 89 .S PSUT5=PSUT5_PSUT8(S2) ;Second tab position 90 ; 91 S PSUT10=" " 92 F S3=1:1:(PSUT6-1) S PSUT9(S3)=" " D 93 .S PSUT10=PSUT10_PSUT9(S3) ;Third tab position 94 ; 95 ; 96 ;I '$D(^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN)) D 97 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN)=PSUIP_PSUT4_PSUNAM_" ("_PSUSSN3_")"_PSUT5_PSUMIS 98 F I=1:1:5 I $P($G(^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN-I)),U,1)[PSUNAM D 99 .S ^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN)=PSUT10_PSUMIS 100 ; 101 I $P($G(^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN)),U,1)[PSUNAM D 102 .S PSUM=PSUM+1 ;Set a counter for number of patients accessed 103 .S ^XTMP("PSU_"_PSUJOB,"PSUSUM",6)="Total Number of Incomplete Provider Records Extracted: "_PSUM 104 S PSULN=PSULN+1 105 ; 106 Q 1 PSUSUM1 ;BIR/DAM - Summary Report for Provider Extract ; 20 DEC 2001 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005 3 ; 4 ; No DBIA's required. 5 ; 6 EN ;EN CALLED FROM ^PSUDEM4 7 ; 8 D PULL^PSUCP 9 D DATE 10 D PRSUM^PSUDEM5 ;Mail message 11 Q 12 ; 13 DATE ;Convert dates to external format 14 ; 15 S %H=$E($H,1,5) ;today's date 16 D YX^%DTC 17 N PSUD S PSUD=Y 18 ; 19 S Y=PSUSDT ;Start date of extract 20 D DD^%DT 21 N PSUS S PSUS=Y 22 ; 23 S Y=PSUEDT ;End date of extract 24 D DD^%DT 25 N PSUE S PSUE=Y 26 ; 27 D SUMM 28 Q 29 ; 30 SUMM ;Compose summary mail message by placing all text into a 31 ;temporary global, designated ^XTMP("PSU_"_PSUJOB,"PSUSUM", 32 ; 33 ; 34 ;Report header 35 I '$D(^XTMP("PSU_"_PSUJOB,"PSUPROV")) D Q 36 .S ^XTMP("PSU_"_PSUJOB,"PSUSUM",1)="No data to report" 37 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",1)="Provider Summary Report "_PSUD 38 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",2)="" ;Blank line 39 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",3)=" "_PSUS_" through "_PSUE 40 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",4)="" 41 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUM",5),"-",80)="" ;Separator Bar 42 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUM",7),"-",80)="" 43 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",8)="" 44 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",9)="IEN Provider Name (SSN) Missing Data" 45 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUM",10),"-",80)="" 46 D PROV 47 ; 48 Q 49 ; 50 PROV ;Gather missing provider data for summary report 51 ; 52 N PSUSSN3,PSUMIS,PSUCL,PSUSS,PSUSP,PSUSUB,PSULN,PSUM 53 S PSUM=0 54 S PSULN=11 55 S PSUIP=0 56 F S PSUIP=$O(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)) Q:PSUIP="" Q:PSUIP["U" D 57 .S PSUSSN3=$E($P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,3),6,9) 58 .I PSUSSN3="" S PSUSSN3="????",PSUMIS="SSN" D NAM ;No SSN 59 .S PSUCL=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,5) 60 .I PSUCL="" S PSUMIS="PROVIDER CLASS" D NAM ;No Class 61 .S PSUSS=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,6) 62 .I PSUSS="" S PSUMIS="SERVICE/SECTION" D NAM ;No Ser/Sec 63 .S PSUSP=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,7) 64 .I PSUSP="" S PSUMIS="SPECIALTY" D NAM ;No Spec 65 .Q:PSUSP["Intern" ;Omit interns from missing subspec. on report 66 .Q:PSUSP["Resident" ;Omit residents from missing subspc. on report 67 .S PSUSUB=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,8) 68 .I PSUSUB="" S PSUMIS="SUBSPECIALTY" D NAM ;No Subsp 69 Q 70 ; 71 NAM ;Get Provider name and create entry line in summary report 72 ; 73 N PSUNAM,PSUT1,PSUT2,PSUT3,PSUT4,S1,S2,S3 74 N PSUT5,PSUT6,PSUT7,PSUT8,PSUT9,PSUT10 75 ; 76 S PSUT4=" " 77 S PSUT1=11 78 S PSUT2=PSUT1-$L(PSUIP) 79 F S1=1:1:(PSUT2-1) S PSUT3(S1)=" " D 80 .S PSUT4=PSUT4_PSUT3(S1) ;First tab position 81 ; 82 S PSUNAM=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,9) 83 ; 84 S PSUT5=" " 85 S PSUT6=54 86 S PSUT7=(PSUT6-$L(PSUNAM)-7-$L(PSUT4)-$L(PSUIP)) 87 F S2=1:1:(PSUT7-1) S PSUT8(S2)=" " D 88 .S PSUT5=PSUT5_PSUT8(S2) ;Second tab position 89 ; 90 S PSUT10=" " 91 F S3=1:1:(PSUT6-1) S PSUT9(S3)=" " D 92 .S PSUT10=PSUT10_PSUT9(S3) ;Third tab position 93 ; 94 ; 95 ;I '$D(^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN)) D 96 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN)=PSUIP_PSUT4_PSUNAM_" ("_PSUSSN3_")"_PSUT5_PSUMIS 97 F I=1:1:5 I $P($G(^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN-I)),U,1)[PSUNAM D 98 .S ^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN)=PSUT10_PSUMIS 99 ; 100 I $P($G(^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN)),U,1)[PSUNAM D 101 .S PSUM=PSUM+1 ;Set a counter for number of patients accessed 102 .S ^XTMP("PSU_"_PSUJOB,"PSUSUM",6)="Total Number of Incomplete Provider Records Extracted: "_PSUM 103 S PSULN=PSULN+1 104 ; 105 Q -
WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUVIT1.m
r613 r623 1 PSUVIT1 ;BIR/RDC - VITALS & IMMUNIZATION EXTRACT; 24 DEC 2003 ; 10/9/07 7:03am 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**11**;MARCH, 2005;Build 8 3 ; 4 ;DBIA's 5 ;References to file #4 - the INSTITUTION file 6 ; DBIA 10090 for: the STATION field - #99 7 ; 8 ;References to file #120.5 - the GMRV VITAL MEASUREMENT file 9 ; DBIA 1381 for: the DATE/TIME VITALS TAKEN field - #.01 10 ; the VITAL TYPE field #.03 11 ; the RATE field #1.2 12 ; the QUALIFIER field #5 13 ; 14 ;References to file #120.51- the GMRV VITAL TYPE file 15 ; DBIA 1382 for: the NAME field - #.01 16 ; 17 ;References to file #120.52 - the GMRV VITAL QUALIFIER file 18 ; DBIA 4504 for: the QUALIFIER field #.01 19 ; 20 ;References to file #9000010.11 - the V IMMUNIZATION file 21 ; DBIA 4567 for: the EVENT DATE AND TIME field #1202 22 ; the IMMUNIZATION field #.01 23 ; 24 ;References to file #2 - the PATIENT file 25 ; DBIA 10035 for: the SOCIAL SECURITY NUMBER field #.09 26 ; DBIA 3504 for: the TEST PATIENT INDICATOR field #.6 27 ; 28 ;References to file #9999999.14 - the IMMUNIZATION file 29 ; DBIA 2454 for: the NAME field #.01 30 ; 31 EN ;ENtry POINT - Routine control module 32 ; 33 N SDATE,EDATE,PSUFAC,PSUIDATE,PSUQCNT,PSUQNUM 34 N MAXLINE,LINECNT,MSGCNT,I,J,K,Z,LINETOT 35 S PSUVTMP(0)="TEMP ARRAY FOR PSUVIT1 PROCESSING" 36 D SETUP 37 D VITALS 38 D VITALS2 39 D IMMUNS 40 D MAILIT 41 Q ; ** end of routine control module ** 42 ; 43 SETUP ; SET UP PARTITION FOR VITALS/IMMUNIZATION EXTRACT 44 ; 45 S LINEMAX=$$VAL^PSUTL(4.3,1,8.3) ; ** get maximum line length ** 46 S:LINEMAX=""!(LINEMAX>10000) LINEMAX=10000 47 ; 48 ; SET EXTRACT DATE 49 S %H=$H 50 D YMD^%DTC 51 S $P(^TMP("PSUVI",$J),U,3)=X 52 ; 53 ; GET TIME WINDOW 54 S SDATE=PSUSDT\1-.0001 55 S EDATE=PSUEDT\1+.2359 56 ; 57 ; GET FACILITY 58 S PSUFAC=PSUSNDR 59 ; 60 ; SET VARIABLES 61 I $G(^XTMP("PSU_"_PSUJOB,"PSUPSUFLAG"))=1 D ;AUTOJOBED 62 . S PSUOPTS="1,2,3,4,5,6,7,8,9,10,11,12,13" 63 . S PSUAUTO=1 64 S LINECNT=999999 65 S LINETOT=0 66 ; 67 Q ; ** end of SETUP ** 68 ; 69 VITALS ; EXTRACT VITAL DATA 70 ; 71 N PSUDATE,PSUV,PSUQ,PSUVREC,PSUPTREC,PSUPTPTR,PSUVPTR,PSUQPTR 72 N PSURTYPE,PSUSSN,PSUICN,PSUVTYPE,PSUVRATE,PSUVUNIT 73 N Z,QQ,PSUVQ1,PSUVQ2,PSUVQ3,PSUVQ4,PSUVLIST,PSUVMSG 74 N PSULN,PSUTXT 75 ; 76 S PSUVLIST="""BLOOD PRESSURE"",""HEIGHT"",""WEIGHT"",""PAIN"",""PULSE"",""PULSE OXIMETRY""" 77 ; 78 ; ** Loop through date index for valid dates ** 79 S PSUDATE=SDATE 80 ;PSU*4*11 Added null ptr notification. 81 S PSUTXT(1)="The following IEN(s) have a null pointer in the PATIENT (#2) field of" 82 S PSUTXT(2)="the GMRV VITAL MEASUREMENT file (#120.5). Please notify your IRM and" 83 S PSUTXT(3)="submit a remedy ticket for help in evaluating the record." 84 S PSULN=3 85 F S PSUDATE=$O(^GMR(120.5,"B",PSUDATE)) Q:PSUDATE>EDATE!('PSUDATE) D 86 . S PSUV="" ; ** loop thru vitals for each date ** 87 . F S PSUV=$O(^GMR(120.5,"B",PSUDATE,PSUV)) Q:PSUV="" D 88 .. Q:$P($D(^GMR(120.5,PSUV,2)),U) ;** quit if vital entered in error ** 89 .. S PSUVREC=$G(^GMR(120.5,PSUV,0)) Q:'PSUVREC 90 .. S PSUPTPTR=$P(PSUVREC,U,2) ; ** point to PATIENT ** 91 .. I PSUPTPTR="" D Q ; ** quit if no patient pointer ** 92 ... S PSULN=PSULN+1 93 ... S PSUTXT(PSULN)=PSUV 94 .. Q:$G(^DPT(PSUPTPTR,0))="" ; ** quit if no patient record ** 95 .. S PSUPTREC=^DPT(PSUPTPTR,0) ; ** get patient record ** 96 .. S PSUSSN=$P(PSUPTREC,U,9) ; ** get SSN 97 .. Q:$E(PSUSSN,1,5)="00000" ; ** quit if invalid patient ** 98 .. Q:$P(PSUPTREC,U,21)=1 99 .. Q:$P(PSUVREC,U,3)="" ; ** quit if no pointer ** 100 .. S PSUVPTR=$P(PSUVREC,U,3) ; ** point to VITAL ** 101 .. S PSUVTYPE=$P(^GMRD(120.51,PSUVPTR,0),U) ; ** get VITAL TYPE ** 102 .. Q:PSUVLIST'[PSUVTYPE ; ** screen out invalid vital types ** 103 .. S PSURTYPE="V" ; ** set record type ** 104 .. S PSUICN=$$GETICN^MPIF001(PSUPTPTR) ; ** get ICN ** 105 .. I $P(PSUICN,U)="-1" S PSUICN="" 106 .. S PSUVRATE=$P(PSUVREC,U,8) 107 .. S PSUVUNIT="" ; ** set vital unit rate ** 108 .. S:PSUVTYPE="PULSE OXIMETRY" PSUVUNIT="%" 109 .. S:PSUVTYPE="WEIGHT" PSUVUNIT="LBS" 110 .. S:PSUVTYPE="HEIGHT" PSUVUNIT="IN" 111 .. S (PSUVQ1,PSUVQ2,PSUVQ3,PSUVQ4)="" 112 .. D:$D(^GMR(120.5,PSUV,5,0)) ; ** get qualifiers ** 113 ... S (PSUQNUM,PSUQCNT)=0 114 ... F S PSUQNUM=$O(^GMR(120.5,PSUV,5,PSUQNUM)) Q:'+PSUQNUM D 115 .... S PSUQPTR=^GMR(120.5,PSUV,5,PSUQNUM,0) 116 .... S PSUQCNT=PSUQCNT+1 117 .... S QQ="PSUVQ"_PSUQCNT 118 .... S @QQ=$P(^GMRD(120.52,PSUQPTR,0),U) 119 .. S Z="$" 120 .. S PSUVMSG=Z_PSUFAC_Z_PSUDATE_Z_PSURTYPE_Z_PSUSSN_Z_PSUICN_Z_""_Z_PSUVTYPE_Z_PSUVRATE_Z_PSUVUNIT_Z_PSUVQ1_Z_PSUVQ2_Z_PSUVQ3_Z_PSUVQ4_Z 121 .. S PSUVMSG=$TR(PSUVMSG,"^","'") 122 .. S PSUVMSG=$TR(PSUVMSG,Z,U) 123 .. ; ** S PSUVTMP(PSUSSN,PSUVTYPE)=PSUVMSG 124 .. S ^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",PSUSSN,PSUVTYPE)=PSUVMSG 125 ;PSU*4*11 Send null ptr notifications to PBM group. 126 I PSULN>3 D 127 . S XMTEXT="PSUTXT(",XMY("G.PSU PBM")="" 128 . S XMSUB="** PBM vitals extract detected null patient pointer(s) **" 129 . S XMDUZ="Pharmacy Benefits Management Package" 130 . N DIFROM D ^XMD 131 Q 132 ; ** end of vital extract ** 133 VITALS2 ; LOAD SORTED ARRAY INTO ^XTMP 134 ; 135 N VPT,VPTV 136 S VPT="" 137 ; ** F S VPT=$O(PSUVTMP(VPT)) Q:VPT="" D 138 F S VPT=$O(^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",VPT)) Q:VPT="" D 139 . S VPTV="" 140 . ; **F S VPTV=$O(PSUVTMP(VPT,VPTV)) Q:VPTV="" D 141 . F S VPTV=$O(^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",VPT,VPTV)) Q:VPTV="" D 142 .. ; ** S X=PSUVTMP(VPT,VPT ; * LOAD VITAL RECORD 143 .. S X=^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",VPT,VPTV) 144 .. S LINECNT=LINECNT+1 145 .. S LINETOT=LINETOT+1 146 .. I LINECNT>LINEMAX S MSGCNT=$G(MSGCNT)+1,LINECNT=1 147 .. I $L(X)<254 S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=X Q ; load 148 .. F J=254:-1 Q:$E(X,J)="^" 149 .. S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=$E(X,1,J) 150 .. S LINECNT=LINECNT+1 151 .. S LINETOT=LINETOT+1 152 .. S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)="*"_$E(X,J,J+253) 153 Q 154 ; 155 IMMUNS ; 156 N PSUDATE,ICNT,PSUINUM,PSUIREC,PSUPTPTR,PSUPTREC,PSUSSN,PSUIMPTR 157 N PSUIMM,PSUICN,PSURTYPE,PSUIMSG 158 ; 159 S (PSUMCNT,PSUINUM)=0 160 F S PSUINUM=$O(^AUPNVIMM(PSUINUM)) Q:'PSUINUM D 161 . S PSUIDATE=$P($G(^AUPNVIMM(PSUINUM,12)),"U") ; ** get IMM date ** 162 . Q:$P(PSUIDATE,U)="" ; ** quit if date is null ** 163 . Q:PSUIDATE<SDATE!(PSUIDATE>EDATE) ; ** quit if date out of range ** 164 . S PSUIREC=^AUPNVIMM(PSUINUM,0) ; ** get IMM record ** 165 . S PSUPTPTR=$P(PSUIREC,U,2) ; ** pointer to PAT file ** 166 . S PSUPTREC=^DPT(PSUPTPTR,0) ; ** get patient record ** 167 . S PSUSSN=$P(PSUPTREC,U,9) 168 . Q:$E(PSUSSN,1,5)="00000" ; ** quit if invalid patient ** 169 . I $P(PSUPTREC,U,21)=1 Q 170 . S PSUIMPTR=$P(PSUIREC,U) ; ** point to IMM file ** 171 . S PSUIMM=$P(^AUTTIMM(PSUIMPTR,0),U) ; ** get IMM name ** 172 . S PSUICN=$$GETICN^MPIF001(PSUPTPTR) ; ** set ICN ** 173 . I $P(PSUICN,U)="-1" S PSUICN="" 174 . S PSURTYPE="I" ; ** set record type ** 175 . S Z="$" 176 . S PSUIMSG=Z_PSUFAC_Z_PSUIDATE_Z_PSURTYPE_Z_PSUSSN_Z_PSUICN_Z_PSUIMM_Z_""_Z_""_Z_""_Z_""_Z_""_Z_""_Z_""_Z_""_Z 177 . S PSUIMSG=$TR(PSUIMSG,"^","'") 178 . S X=$TR(PSUIMSG,Z,U) 179 . ; *** load ^XTMP *** 180 . S LINECNT=LINECNT+1 181 . S LINETOT=LINETOT+1 182 . I LINECNT>LINEMAX S MSGCNT=$G(MSGCNT)+1,LINECNT=1 183 . I $L(X)<254 S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=X Q ; load 184 . F K=254:-1 Q:$E(X,K)="^" 185 . S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=$E(X,1,K) 186 . S LINECNT=LINECNT+1 187 . S LINETOT=LINETOT+1 188 . S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)="*"_$E(X,K,K+253) 189 ; *** save message count *** 190 S:$G(MSGCNT) ^XTMP("PSU_"_PSUJOB,"PSUVI","MSGTCNT")=MSGCNT 191 S ^XTMP("PSU_"_PSUJOB,"PSUVI","LINECNT")=LINETOT 192 Q ; ** quit IMMUNS ** 193 ; 194 MAILIT ; MAIL VITAL & IMMUNIZATION EXTRACT MESSAGES 195 ; 196 D ^PSUVIT2 197 Q ; ** quit for MAILIT ** 198 ; 1 PSUVIT1 ;BIR/RDC - VITALS & IMMUNIZATION EXTRACT; 24 DEC 2003 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005 3 ; 4 ;DBIA's 5 ;References to file #4 - the INSTITUTION file 6 ; DBIA 10090 for: the STATION field - #99 7 ; 8 ;References to file #120.5 - the GMRV VITAL MEASUREMENT file 9 ; DBIA 1381 for: the DATE/TIME VITALS TAKEN field - #.01 10 ; the VITAL TYPE field #.03 11 ; the RATE field #1.2 12 ; the QUALIFIER field #5 13 ; 14 ;References to file #120.51- the GMRV VITAL TYPE file 15 ; DBIA 1382 for: the NAME field - #.01 16 ; 17 ;References to file #120.52 - the GMRV VITAL QUALIFIER file 18 ; DBIA 4504 for: the QUALIFIER field #.01 19 ; 20 ;References to file #9000010.11 - the V IMMUNIZATION file 21 ; DBIA 4567 for: the EVENT DATE AND TIME field #1202 22 ; the IMMUNIZATION field #.01 23 ; 24 ;References to file #2 - the PATIENT file 25 ; DBIA 10035 for: the SOCIAL SECURITY NUMBER field #.09 26 ; DBIA 3504 for: the TEST PATIENT INDICATOR field #.6 27 ; 28 ;References to file #9999999.14 - the IMMUNIZATION file 29 ; DBIA 2454 for: the NAME field #.01 30 ; 31 EN ;ENtry POINT - Routine control module 32 ; 33 N SDATE,EDATE,PSUFAC,PSUIDATE,PSUQCNT,PSUQNUM 34 N MAXLINE,LINECNT,MSGCNT,I,J,K,Z,LINETOT 35 S PSUVTMP(0)="TEMP ARRAY FOR PSUVIT1 PROCESSING" 36 D SETUP 37 D VITALS 38 D VITALS2 39 D IMMUNS 40 D MAILIT 41 Q ; ** end of routine control module ** 42 ; 43 SETUP ; SET UP PARTITION FOR VITALS/IMMUNIZATION EXTRACT 44 ; 45 S LINEMAX=$$VAL^PSUTL(4.3,1,8.3) ; ** get maximum line length ** 46 S:LINEMAX=""!(LINEMAX>10000) LINEMAX=10000 47 ; 48 ; SET EXTRACT DATE 49 S %H=$H 50 D YMD^%DTC 51 S $P(^TMP("PSUVI",$J),U,3)=X 52 ; 53 ; GET TIME WINDOW 54 S SDATE=PSUSDT\1-.0001 55 S EDATE=PSUEDT\1+.2359 56 ; 57 ; GET FACILITY 58 S PSUFAC=PSUSNDR 59 ; 60 ; SET VARIABLES 61 I $G(^XTMP("PSU_"_PSUJOB,"PSUPSUFLAG"))=1 D ;AUTOJOBED 62 . S PSUOPTS="1,2,3,4,5,6,7,8,9,10,11,12,13" 63 . S PSUAUTO=1 64 S LINECNT=999999 65 S LINETOT=0 66 ; 67 Q ; ** end of SETUP ** 68 ; 69 VITALS ; EXTRACT VITAL DATA 70 ; 71 N PSUDATE,PSUV,PSUQ,PSUVREC,PSUPTREC,PSUPTPTR,PSUVPTR,PSUQPTR 72 N PSURTYPE,PSUSSN,PSUICN,PSUVTYPE,PSUVRATE,PSUVUNIT 73 N Z,QQ,PSUVQ1,PSUVQ2,PSUVQ3,PSUVQ4,PSUVLIST,PSUVMSG 74 ; 75 S PSUVLIST="""BLOOD PRESSURE"",""HEIGHT"",""WEIGHT"",""PAIN"",""PULSE"",""PULSE OXIMETRY""" 76 ; 77 ; ** Loop through date index for valid dates ** 78 S PSUDATE=SDATE 79 F S PSUDATE=$O(^GMR(120.5,"B",PSUDATE)) Q:PSUDATE>EDATE!('PSUDATE) D 80 . S PSUV="" ; ** loop thru vitals for each date ** 81 . F S PSUV=$O(^GMR(120.5,"B",PSUDATE,PSUV)) Q:PSUV="" D 82 .. Q:$P($D(^GMR(120.5,PSUV,2)),U) ;** quit if vital entered in error ** 83 .. S PSUVREC=$G(^GMR(120.5,PSUV,0)) Q:'PSUVREC 84 .. S PSUPTPTR=$P(PSUVREC,U,2) ; ** point to PATIENT ** 85 .. Q:$G(^DPT(PSUPTPTR,0))="" ; ** quit if no patient record ** 86 .. S PSUPTREC=^DPT(PSUPTPTR,0) ; ** get patient record ** 87 .. S PSUSSN=$P(PSUPTREC,U,9) ; ** get SSN 88 .. Q:$E(PSUSSN,1,5)="00000" ; ** quit if invalid patient ** 89 .. Q:$P(PSUPTREC,U,21)=1 90 .. Q:$P(PSUVREC,U,3)="" ; ** quit if no pointer ** 91 .. S PSUVPTR=$P(PSUVREC,U,3) ; ** point to VITAL ** 92 .. S PSUVTYPE=$P(^GMRD(120.51,PSUVPTR,0),U) ; ** get VITAL TYPE ** 93 .. Q:PSUVLIST'[PSUVTYPE ; ** screen out invalid vital types ** 94 .. S PSURTYPE="V" ; ** set record type ** 95 .. S PSUICN=$$GETICN^MPIF001(PSUPTPTR) ; ** get ICN ** 96 .. I $P(PSUICN,U)="-1" S PSUICN="" 97 .. S PSUVRATE=$P(PSUVREC,U,8) 98 .. S PSUVUNIT="" ; ** set vital unit rate ** 99 .. S:PSUVTYPE="PULSE OXIMETRY" PSUVUNIT="%" 100 .. S:PSUVTYPE="WEIGHT" PSUVUNIT="LBS" 101 .. S:PSUVTYPE="HEIGHT" PSUVUNIT="IN" 102 .. S (PSUVQ1,PSUVQ2,PSUVQ3,PSUVQ4)="" 103 .. D:$D(^GMR(120.5,PSUV,5,0)) ; ** get qualifiers ** 104 ... S (PSUQNUM,PSUQCNT)=0 105 ... F S PSUQNUM=$O(^GMR(120.5,PSUV,5,PSUQNUM)) Q:'+PSUQNUM D 106 .... S PSUQPTR=^GMR(120.5,PSUV,5,PSUQNUM,0) 107 .... S PSUQCNT=PSUQCNT+1 108 .... S QQ="PSUVQ"_PSUQCNT 109 .... S @QQ=$P(^GMRD(120.52,PSUQPTR,0),U) 110 .. S Z="$" 111 .. S PSUVMSG=Z_PSUFAC_Z_PSUDATE_Z_PSURTYPE_Z_PSUSSN_Z_PSUICN_Z_""_Z_PSUVTYPE_Z_PSUVRATE_Z_PSUVUNIT_Z_PSUVQ1_Z_PSUVQ2_Z_PSUVQ3_Z_PSUVQ4_Z 112 .. S PSUVMSG=$TR(PSUVMSG,"^","'") 113 .. S PSUVMSG=$TR(PSUVMSG,Z,U) 114 .. ; ** S PSUVTMP(PSUSSN,PSUVTYPE)=PSUVMSG 115 .. S ^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",PSUSSN,PSUVTYPE)=PSUVMSG 116 Q 117 ; ** end of vital extract ** 118 VITALS2 ; LOAD SORTED ARRAY INTO ^XTMP 119 ; 120 N VPT,VPTV 121 S VPT="" 122 ; ** F S VPT=$O(PSUVTMP(VPT)) Q:VPT="" D 123 F S VPT=$O(^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",VPT)) Q:VPT="" D 124 . S VPTV="" 125 . ; **F S VPTV=$O(PSUVTMP(VPT,VPTV)) Q:VPTV="" D 126 . F S VPTV=$O(^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",VPT,VPTV)) Q:VPTV="" D 127 .. ; ** S X=PSUVTMP(VPT,VPT ; * LOAD VITAL RECORD 128 .. S X=^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",VPT,VPTV) 129 .. S LINECNT=LINECNT+1 130 .. S LINETOT=LINETOT+1 131 .. I LINECNT>LINEMAX S MSGCNT=$G(MSGCNT)+1,LINECNT=1 132 .. I $L(X)<254 S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=X Q ; load 133 .. F J=254:-1 Q:$E(X,J)="^" 134 .. S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=$E(X,1,J) 135 .. S LINECNT=LINECNT+1 136 .. S LINETOT=LINETOT+1 137 .. S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)="*"_$E(X,J,J+253) 138 Q 139 ; 140 IMMUNS ; 141 N PSUDATE,ICNT,PSUINUM,PSUIREC,PSUPTPTR,PSUPTREC,PSUSSN,PSUIMPTR 142 N PSUIMM,PSUICN,PSURTYPE,PSUIMSG 143 ; 144 S (PSUMCNT,PSUINUM)=0 145 F S PSUINUM=$O(^AUPNVIMM(PSUINUM)) Q:'PSUINUM D 146 . S PSUIDATE=$P($G(^AUPNVIMM(PSUINUM,12)),"U") ; ** get IMM date ** 147 . Q:$P(PSUIDATE,U)="" ; ** quit if date is null ** 148 . Q:PSUIDATE<SDATE!(PSUIDATE>EDATE) ; ** quit if date out of range ** 149 . S PSUIREC=^AUPNVIMM(PSUINUM,0) ; ** get IMM record ** 150 . S PSUPTPTR=$P(PSUIREC,U,2) ; ** pointer to PAT file ** 151 . S PSUPTREC=^DPT(PSUPTPTR,0) ; ** get patient record ** 152 . S PSUSSN=$P(PSUPTREC,U,9) 153 . Q:$E(PSUSSN,1,5)="00000" ; ** quit if invalid patient ** 154 . I $P(PSUPTREC,U,21)=1 Q 155 . S PSUIMPTR=$P(PSUIREC,U) ; ** point to IMM file ** 156 . S PSUIMM=$P(^AUTTIMM(PSUIMPTR,0),U) ; ** get IMM name ** 157 . S PSUICN=$$GETICN^MPIF001(PSUPTPTR) ; ** set ICN ** 158 . I $P(PSUICN,U)="-1" S PSUICN="" 159 . S PSURTYPE="I" ; ** set record type ** 160 . S Z="$" 161 . S PSUIMSG=Z_PSUFAC_Z_PSUIDATE_Z_PSURTYPE_Z_PSUSSN_Z_PSUICN_Z_PSUIMM_Z_""_Z_""_Z_""_Z_""_Z_""_Z_""_Z_""_Z_""_Z 162 . S PSUIMSG=$TR(PSUIMSG,"^","'") 163 . S X=$TR(PSUIMSG,Z,U) 164 . ; *** load ^XTMP *** 165 . S LINECNT=LINECNT+1 166 . S LINETOT=LINETOT+1 167 . I LINECNT>LINEMAX S MSGCNT=$G(MSGCNT)+1,LINECNT=1 168 . I $L(X)<254 S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=X Q ; load 169 . F K=254:-1 Q:$E(X,K)="^" 170 . S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=$E(X,1,K) 171 . S LINECNT=LINECNT+1 172 . S LINETOT=LINETOT+1 173 . S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)="*"_$E(X,K,K+253) 174 ; *** save message count *** 175 S:$G(MSGCNT) ^XTMP("PSU_"_PSUJOB,"PSUVI","MSGTCNT")=MSGCNT 176 S ^XTMP("PSU_"_PSUJOB,"PSUVI","LINECNT")=LINETOT 177 Q ; ** quit IMMUNS ** 178 ; 179 MAILIT ; MAIL VITAL & IMMUNIZATION EXTRACT MESSAGES 180 ; 181 D ^PSUVIT2 182 Q ; ** quit for MAILIT ** 183 ;
Note:
See TracChangeset
for help on using the changeset viewer.
