Changeset 623 for WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL5.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL5.m
r613 r623 1 ECXUTL5 ;ALB/JRC - Utilities for DSS Extracts ; 10/17/07 3:49pm 2 ;;3.0;DSS EXTRACTS;**71,84,92,103,105**;Dec 22, 1997;Build 70 3 ; 4 REPEAT(CHAR,TIMES) ;REPEAT A STRING 5 ;INPUT : CHAR - Character to repeat 6 ; TIMES - Number of times to repeat CHAR 7 ;OUTPUT : s - String of CHAR that is TIMES long 8 ; "" - Error (bad input) 9 ; 10 ;CHECK INPUT 11 Q:($G(CHAR)="") "" 12 Q:((+$G(TIMES))=0) "" 13 ;RETURN STRING 14 Q $TR($J("",TIMES)," ",CHAR) 15 INSERT(INSTR,OUTSTR,COLUMN,LENGTH) ;INSERT A STRING INTO ANOTHER 16 ;INPUT : INSTR - String to insert 17 ; OUTSTR - String to insert into 18 ; COLUMN - Where to begin insertion (defaults to end of OUTSTR) 19 ; LENGTH - Number of characters to clear from OUTSTR 20 ; (defaults to length of INSTR) 21 ;OUTPUT : s - INSTR will be placed into OUTSTR starting at COLUMN 22 ; using LENGTH characters 23 ; "" - Error (bad input) 24 ; 25 ;NOTE : This module is based on $$SETSTR^VALM1 26 ; 27 ;CHECK INPUT 28 Q:('$D(INSTR)) "" 29 Q:('$D(OUTSTR)) "" 30 S:('$D(COLUMN)) COLUMN=$L(OUTSTR)+1 31 S:('$D(LENGTH)) LENGTH=$L(INSTR) 32 ;DECLARE VARIABLES 33 N FRONT,END 34 S FRONT=$E((OUTSTR_$J("",COLUMN-1)),1,(COLUMN-1)) 35 S END=$E(OUTSTR,(COLUMN+LENGTH),$L(OUTSTR)) 36 ;INSERT STRING 37 Q FRONT_$E((INSTR_$J("",LENGTH)),1,LENGTH)_END 38 TYPE(DFN) ;Determine patient type DBIA #2511 39 ; input 40 ; DFN = patient ien 41 ; 42 ; output 43 ; ECXPTYPE = patient type external value from fle 391 44 ; 45 ; AC = ACTIVE DUTY MI = MILITARY RETIREE 46 ; AL = ALLIED VETERAN NO = NON-VETERAN (OTHER) 47 ; CO = COLLATERAL NS = NSC VETERAN 48 ; EM = EMPLOYEE SC = SC VETERAN 49 ; IN = INELIGIBLE TR = TRICARE 50 ; return value 0 if no data found, 1 if data found 51 ; 52 N TYPE,ECXPTYPE 53 ;Check input 54 Q:'$D(DFN) "" 55 S (TYPE,ECXPTYPE)="" 56 S TYPE=$G(^DPT(DFN,"TYPE")) 57 I 'TYPE Q ECXPTYPE 58 S ECXPTYPE=$P($G(^DG(391,TYPE,0)),U,1) 59 S ECXPTYPE=$E(ECXPTYPE,1,2) 60 Q ECXPTYPE 61 CVEDT(DFN,DATE) ;Determine patient CV status DBIA #4156 62 ; input 63 ; DFN = patient ien 64 ; 65 ; output 66 ; ECXCVE = combat veteran status eligibility 67 ; ECXCVEDT = combat veteran eligibility end date 68 ; ECXCVENC = combat veteran encounter 69 ;Initialize variables 70 N CVSTAT 71 S (CVSTAT,ECXCVE,ECXCVEDT,ECXCVENC)="" 72 ;Check input 73 Q:'$D(DFN) 0 74 ;Call CV API 75 S CVSTAT=$$CVEDT^DGCV(DFN,DATE) 76 I CVSTAT<1 Q 0 77 ;Veteran been given CV eligibility 78 S ECXCVE=$S($P(CVSTAT,U,3)=1:"Y",$P(CVSTAT,U,3)=0:"E",1:"") 79 ;Save CV eligibility end date and convert from FM to HL7 format 80 S ECXCVEDT=$P(CVSTAT,U,2) 81 S ECXCVEDT=$$FMTHL7^XLFDT(ECXCVEDT) 82 ;Is the veteran eligible for CV in the date of encounter 83 S ECXCVENC=$S($P(CVSTAT,U,3)=1:"Y",1:"") 84 Q 1 85 NPRF ;National patient record flags DBIA #3860 86 N ECXARR,FLG 87 S ECXNPRFI="",CNT=$$GETACT^DGPFAPI(ECXDFN,"ECXARR"),FLG="" 88 I 'CNT Q 89 F I=1:1:CNT D Q:FLG 90 .I ECXARR(I,"CATEGORY")["NATIONAL" S ECXNPRFI="Y",FLG=1 91 Q 92 RXPTST(K) ;Rx patient status DBIA #2511 93 N ECXDIC,STAT 94 S (ECXDIC,STAT)="" 95 ;Check input 96 Q:'$D(K) STAT 97 S DA=K,DIC="^PS(53,",DIQ(0)="I",DIQ="ECXDIC",DR="6" 98 D EN^DIQ1 99 S STAT=$G(ECXDIC(53,K,6,"I")) 100 S STAT=$S(STAT=1:"SC",STAT=2:"AA",STAT=3:"OTH",STAT=4:"INP",STAT=5:"NON",1:"") 101 Q STAT 102 NONVAP(K) ;Non-va prescriber DBIA #10060 103 N ECXDIC,NONVAP 104 S (ECXDIC,NONVAP)="" 105 Q:'$D(K) NONVAP 106 S DA=K,DIC="^VA(200,",DIQ(0)="I",DIQ="ECXDIC",DR="53.91" 107 D EN^DIQ1 108 S NONVAP=$G(ECXDIC(200,K,53.91,"I")) 109 I NONVAP S NONVAP="Y" 110 Q NONVAP 111 DOIVPO(K,L) ;Add destination for outpatient ivp orders 112 ; Input K - DFN 113 ; L - Order # from Pharmacy Patient File (#55) 114 ; 115 ; Output ordering stop code 116 ; 117 N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA 118 S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)="" 119 ;Check input 120 Q:'K!'(L) SCODE 121 ;Check treating specialty 122 S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE 123 ;Go to pharmacy patient file (#55) and return value of field (#136) 124 S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="100",DR(55.01)="136",DA=K,DA(55.01)=L 125 D EN^DIQ1 126 S CLINIC=$G(ECXDIC(55.01,L,136,"I")) 127 I 'CLINIC Q SCODE 128 ;Get stop code pointer to file 40.7 from file 44 129 S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1 130 S SCODE=ECXDICA(44,CLINIC,8,"I") 131 ;Get stop code external value 132 S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1",DA=SCODE D EN^DIQ1 133 S SCODE=$G(ECXDICB(40.7,SCODE,1,"E")) 134 Q SCODE 135 ; 136 DOUDO(K,L) ;Add destination for outpatient udp orders 137 ; Input K - DFN 138 ; L - Order # from Pharmacy Patient File (#55) 139 ; 140 ; Output ordering stop code 141 ; 142 N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA 143 S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)="" 144 ;Check treating specialty 145 S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE 146 ;Check input 147 Q:'K!'(L) SCODE 148 S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="62",DR(55.06)="130",DA=K,DA(55.06)=L 149 D EN^DIQ1 150 S CLINIC=$G(ECXDIC(55.06,L,130,"I")) 151 I 'CLINIC Q SCODE 152 ;Get stop code pointer to file 40.7 from file 44 153 S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1 154 S SCODE=ECXDICA(44,CLINIC,8,"I") 155 ;Get stop code external value 156 S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1",DA=SCODE D EN^DIQ1 157 S SCODE=$G(ECXDICB(40.7,SCODE,1,"E")) 158 Q SCODE 159 ; 160 PHAAPI(DRUG) ;Call Pharmacy drug file API dbia 4483 161 ; Input: drug file (#50) ien 162 ; 163 ; Output: generic name ^ classification ^ ndc ^ dea hand 164 ; ^ ndf file entry # ^ psndf va product entry ^ 165 ; price per disp unit ^ dispense unit 166 ; 167 ;Initialize variables and scratch global 168 N NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,UNIT,ARRAY,DATA 169 S (NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,ARRAY,DATA)="" 170 S ARRAY="^TMP($J,""ECXLIST"")" 171 K @ARRAY 172 D DATA^PSS50(DRUG,,,,,"ECXLIST") 173 I @ARRAY@(0)'>0 Q "^^^^^^" 174 S NAME=@ARRAY@(DRUG,.01),CLASS=@ARRAY@(DRUG,2),NDC=@ARRAY@(DRUG,31) 175 S INV=@ARRAY@(DRUG,3),P1=$P(@ARRAY@(DRUG,20),U),P3=$P(@ARRAY@(DRUG,22),U),PPDU=@ARRAY@(DRUG,16),UNIT=@ARRAY@(DRUG,14.5) 176 K @ARRAY 177 Q NAME_U_CLASS_U_NDC_U_INV_U_P1_U_P3_U_PPDU_U_UNIT 178 ; 179 TSSC(X) ;Check treating specialty (ts) and if ts equals any of the following 180 ;18,23,24,36,41,65,94 then assign predefined code and return value 181 ; 182 ; Input: treating specialty 183 ; Output: Ordering stop code 184 ; 185 S CODE=$S(X=18:293,X=23:295,X=24:290,X=36:294,X=41:296,X=65:291,X=94:292,1:"") 186 Q CODE 187 ; 188 PSJ59P5(X) ;Get iv room division 189 ; Input X - iv room ien 190 ; 191 ; Output - field .02 division 192 ;Init variables 193 N DIV S DIV="" 194 ;Check input 195 I 'X Q DIV 196 D ALL^PSJ59P5(X,,"ECXDIV") 197 S DIV=$P($G(^TMP($J,"ECXDIV",X,.02)),U) 198 K ^TMP($J,"ECXDIV") 199 Q DIV 200 ; 201 SCRX(IEN) ;Service connected prescription 202 ;Init variables 203 N DIC,DR,DA,ECXDIQ 204 ;Check input 205 I '$G(IEN) Q "" 206 S DIC=52,DR="116",DA=IEN,DIQ="ECXDIQ" 207 D DIQ^PSODI(DIC,DIC,DR,DA,DIQ) 208 Q $S($G(ECXDIQ(52,DA,116))="YES":"Y",$G(ECXDIQ(52,DA,116))="NO":"N",1:"") 209 ; 210 SSN(SSN,FILE) ; extended validation of ssn 211 ; input: ssn - social security number to validate 212 ; file - optional "", 2 or 67, the only check is for 213 ; reference lab file (#67) in which case ssn 214 ; "000123456" is considered a valid ssn. 215 ; output: 0 - test patient or invalid ssn 216 ; 1 - valid ssn 217 ; 218 ;check input 219 I $G(SSN)']"" Q 0 220 S FILE=$G(FILE) 221 I (FILE=67)&(SSN="000123456") Q 1 222 I "89"[$E(SSN) Q 0 223 I (SSN="123456789")!(SSN="111111111")!(SSN="222222222")!(SSN="333333333")!(SSN="444444444")!(SSN="555555555")!($E(SSN,1,3)="666")!($E(SSN,4,5)="00")!($E(SSN,1,3)="000") Q 0 224 Q 1 1 ECXUTL5 ;ALB/JRC - Utilities for DSS Extracts ; 01/18/07 9:04am 2 ;;3.0;DSS EXTRACTS;**71,84,92,103**;Dec 22, 1997;Build 1 3 ; 4 REPEAT(CHAR,TIMES) ;REPEAT A STRING 5 ;INPUT : CHAR - Character to repeat 6 ; TIMES - Number of times to repeat CHAR 7 ;OUTPUT : s - String of CHAR that is TIMES long 8 ; "" - Error (bad input) 9 ; 10 ;CHECK INPUT 11 Q:($G(CHAR)="") "" 12 Q:((+$G(TIMES))=0) "" 13 ;RETURN STRING 14 Q $TR($J("",TIMES)," ",CHAR) 15 INSERT(INSTR,OUTSTR,COLUMN,LENGTH) ;INSERT A STRING INTO ANOTHER 16 ;INPUT : INSTR - String to insert 17 ; OUTSTR - String to insert into 18 ; COLUMN - Where to begin insertion (defaults to end of OUTSTR) 19 ; LENGTH - Number of characters to clear from OUTSTR 20 ; (defaults to length of INSTR) 21 ;OUTPUT : s - INSTR will be placed into OUTSTR starting at COLUMN 22 ; using LENGTH characters 23 ; "" - Error (bad input) 24 ; 25 ;NOTE : This module is based on $$SETSTR^VALM1 26 ; 27 ;CHECK INPUT 28 Q:('$D(INSTR)) "" 29 Q:('$D(OUTSTR)) "" 30 S:('$D(COLUMN)) COLUMN=$L(OUTSTR)+1 31 S:('$D(LENGTH)) LENGTH=$L(INSTR) 32 ;DECLARE VARIABLES 33 N FRONT,END 34 S FRONT=$E((OUTSTR_$J("",COLUMN-1)),1,(COLUMN-1)) 35 S END=$E(OUTSTR,(COLUMN+LENGTH),$L(OUTSTR)) 36 ;INSERT STRING 37 Q FRONT_$E((INSTR_$J("",LENGTH)),1,LENGTH)_END 38 TYPE(DFN) ;Determine patient type DBIA #2511 39 ; input 40 ; DFN = patient ien 41 ; 42 ; output 43 ; ECXPTYPE = patient type external value from fle 391 44 ; 45 ; AC = ACTIVE DUTY MI = MILITARY RETIREE 46 ; AL = ALLIED VETERAN NO = NON-VETERAN (OTHER) 47 ; CO = COLLATERAL NS = NSC VETERAN 48 ; EM = EMPLOYEE SC = SC VETERAN 49 ; IN = INELIGIBLE TR = TRICARE 50 ; return value 0 if no data found, 1 if data found 51 ; 52 N TYPE,ECXPTYPE 53 ;Check input 54 Q:'$D(DFN) "" 55 S (TYPE,ECXPTYPE)="" 56 S TYPE=$G(^DPT(DFN,"TYPE")) 57 I 'TYPE Q ECXPTYPE 58 S ECXPTYPE=$P($G(^DG(391,TYPE,0)),U,1) 59 S ECXPTYPE=$E(ECXPTYPE,1,2) 60 Q ECXPTYPE 61 CVEDT(DFN,DATE) ;Determine patient CV status DBIA #4156 62 ; input 63 ; DFN = patient ien 64 ; 65 ; output 66 ; ECXCVE = combat veteran status eligibility 67 ; ECXCVEDT = combat veteran eligibility end date 68 ; ECXCVENC = combat veteran encounter 69 ;Initialize variables 70 N CVSTAT 71 S (CVSTAT,ECXCVE,ECXCVEDT,ECXCVENC)="" 72 ;Check input 73 Q:'$D(DFN) 0 74 ;Call CV API 75 S CVSTAT=$$CVEDT^DGCV(DFN,DATE) 76 I CVSTAT<1 Q 0 77 ;Veteran been given CV eligibility 78 S ECXCVE=$S($P(CVSTAT,U,3)=1:"Y",$P(CVSTAT,U,3)=0:"E",1:"") 79 ;Save CV eligibility end date and convert from FM to HL7 format 80 S ECXCVEDT=$P(CVSTAT,U,2) 81 S ECXCVEDT=$$FMTHL7^XLFDT(ECXCVEDT) 82 ;Is the veteran eligible for CV in the date of encounter 83 S ECXCVENC=$S($P(CVSTAT,U,3)=1:"Y",1:"") 84 Q 1 85 NPRF ;National patient record flags DBIA #3860 86 N ECXARR,FLG 87 S ECXNPRFI="",CNT=$$GETACT^DGPFAPI(ECXDFN,"ECXARR"),FLG="" 88 I 'CNT Q 89 F I=1:1:CNT D Q:FLG 90 .I ECXARR(I,"CATEGORY")["NATIONAL" S ECXNPRFI="Y",FLG=1 91 Q 92 RXPTST(K) ;Rx patient status DBIA #2511 93 N ECXDIC,STAT 94 S (ECXDIC,STAT)="" 95 ;Check input 96 Q:'$D(K) STAT 97 S DA=K,DIC="^PS(53,",DIQ(0)="I",DIQ="ECXDIC",DR="6" 98 D EN^DIQ1 99 S STAT=$G(ECXDIC(53,K,6,"I")) 100 S STAT=$S(STAT=1:"SC",STAT=2:"AA",STAT=3:"OTH",STAT=4:"INP",STAT=5:"NON",1:"") 101 Q STAT 102 NONVAP(K) ;Non-va prescriber DBIA #10060 103 N ECXDIC,NONVAP 104 S (ECXDIC,NONVAP)="" 105 Q:'$D(K) NONVAP 106 S DA=K,DIC="^VA(200,",DIQ(0)="I",DIQ="ECXDIC",DR="53.91" 107 D EN^DIQ1 108 S NONVAP=$G(ECXDIC(200,K,53.91,"I")) 109 I NONVAP S NONVAP="Y" 110 Q NONVAP 111 DOIVPO(K,L) ;Add destination for outpatient ivp orders 112 ; Input K - DFN 113 ; L - Order # from Pharmacy Patient File (#55) 114 ; 115 ; Output ordering stop code 116 ; 117 N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA 118 S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)="" 119 ;Check input 120 Q:'K!'(L) SCODE 121 ;Check treating specialty 122 S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE 123 ;Go to pharmacy patient file (#55) and return value of field (#136) 124 S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="100",DR(55.01)="136",DA=K,DA(55.01)=L 125 D EN^DIQ1 126 S CLINIC=$G(ECXDIC(55.01,L,136,"I")) 127 I 'CLINIC Q SCODE 128 ;Get stop code pointer to file 40.7 from file 44 129 S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1 130 S SCODE=ECXDICA(44,CLINIC,8,"I") 131 ;Get stop code external value 132 S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1",DA=SCODE D EN^DIQ1 133 S SCODE=$G(ECXDICB(40.7,SCODE,1,"E")) 134 Q SCODE 135 ; 136 DOUDO(K,L) ;Add destination for outpatient udp orders 137 ; Input K - DFN 138 ; L - Order # from Pharmacy Patient File (#55) 139 ; 140 ; Output ordering stop code 141 ; 142 N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA 143 S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)="" 144 ;Check treating specialty 145 S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE 146 ;Check input 147 Q:'K!'(L) SCODE 148 S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="62",DR(55.06)="130",DA=K,DA(55.06)=L 149 D EN^DIQ1 150 S CLINIC=$G(ECXDIC(55.06,L,130,"I")) 151 I 'CLINIC Q SCODE 152 ;Get stop code pointer to file 40.7 from file 44 153 S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1 154 S SCODE=ECXDICA(44,CLINIC,8,"I") 155 ;Get stop code external value 156 S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1",DA=SCODE D EN^DIQ1 157 S SCODE=$G(ECXDICB(40.7,SCODE,1,"E")) 158 Q SCODE 159 ; 160 PHAAPI(DRUG) ;Call Pharmacy drug file API dbia 4483 161 ; Input: drug file (#50) ien 162 ; 163 ; Output: generic name ^ classification ^ ndc ^ dea hand 164 ; ^ ndf file entry # ^ psndf va product entry ^ 165 ; price per disp unit ^ dispense unit 166 ; 167 ;Initialize variables and scratch global 168 N NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,UNIT,ARRAY,DATA 169 S (NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,ARRAY,DATA)="" 170 S ARRAY="^TMP($J,""ECXLIST"")" 171 K @ARRAY 172 D DATA^PSS50(DRUG,,,,,"ECXLIST") 173 I @ARRAY@(0)'>0 Q "^^^^^^" 174 S NAME=@ARRAY@(DRUG,.01),CLASS=@ARRAY@(DRUG,2),NDC=@ARRAY@(DRUG,31) 175 S INV=@ARRAY@(DRUG,3),P1=$P(@ARRAY@(DRUG,20),U),P3=$P(@ARRAY@(DRUG,22),U),PPDU=@ARRAY@(DRUG,16),UNIT=@ARRAY@(DRUG,14.5) 176 K @ARRAY 177 Q NAME_U_CLASS_U_NDC_U_INV_U_P1_U_P3_U_PPDU_U_UNIT 178 ; 179 TSSC(X) ;Check treating specialty (ts) and if ts equals any of the following 180 ;18,23,24,36,41,65,94 then assign predefined code and return value 181 ; 182 ; Input: treating specialty 183 ; Output: Ordering stop code 184 ; 185 S CODE=$S(X=18:293,X=23:295,X=24:290,X=36:294,X=41:296,X=65:291,X=94:292,1:"") 186 Q CODE 187 ; 188 PSJ59P5(X) ;Get iv room division 189 ; Input X - iv room ien 190 ; 191 ; Output - field .02 division 192 ;Init variables 193 N DIV S DIV="" 194 ;Check input 195 I 'X Q DIV 196 D ALL^PSJ59P5(X,,"ECXDIV") 197 S DIV=$P($G(^TMP($J,"ECXDIV",X,.02)),U) 198 K ^TMP($J,"ECXDIV") 199 Q DIV 200 ; 201 SCRX(IEN) ;Service connected prescription 202 ;Init variables 203 N DIC,DR,DA,ECXDIQ 204 ;Check input 205 I '$G(IEN) Q "" 206 S DIC=52,DR="116",DA=IEN,DIQ="ECXDIQ" 207 D DIQ^PSODI(DIC,DIC,DR,DA,DIQ) 208 Q $S($G(ECXDIQ(52,DA,116))="YES":"Y",$G(ECXDIQ(52,DA,116))="NO":"N",1:"")
Note:
See TracChangeset
for help on using the changeset viewer.