Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ECXUTL5

ECXUTL5.m

Go to the documentation of this file. 
  1. ECXUTL5 ;ALB/JRC - Utilities for DSS Extracts ;5/9/19  16:31
  1.  ;;3.0;DSS EXTRACTS;**71,84,92,103,105,120,136,166,170,174,181,184,187**;Dec 22, 1997;Build 163
  1.  ;
  1.  ; Reference to ^DPT( in ICR #1850
  1.  ; Reference to $$CVEDT^DGCV in ICR #4156
  1.  ; Reference to $$GETACT^DGPFAPI in ICR #3860 
  1.  ; Reference to ALL^PSJ59P5 Supported #4819
  1.  ; Reference to DATA^PSS50 Supported #4533
  1.  ; Reference to DIQ^PSODI in ICR #4858
  1.  ; Reference to ^TMP($J supported by SACC 2.3.2.5.1
  1.  ;
  1. REPEAT(CHAR,TIMES) ;REPEAT A STRING
  1.  ;INPUT  : CHAR - Character to repeat
  1.  ;         TIMES - Number of times to repeat CHAR
  1.  ;OUTPUT : s - String of CHAR that is TIMES long
  1.  ;         "" - Error (bad input)
  1.  ;
  1.  ;CHECK INPUT
  1.  Q:($G(CHAR)="") ""
  1.  Q:((+$G(TIMES))=0) ""
  1.  ;RETURN STRING
  1.  Q $TR($J("",TIMES)," ",CHAR)
  1. INSERT(INSTR,OUTSTR,COLUMN,LENGTH) ;INSERT A STRING INTO ANOTHER
  1.  ;INPUT  : INSTR - String to insert
  1.  ;         OUTSTR - String to insert into
  1.  ;         COLUMN - Where to begin insertion (defaults to end of OUTSTR)
  1.  ;         LENGTH - Number of characters to clear from OUTSTR
  1.  ;                  (defaults to length of INSTR)
  1.  ;OUTPUT : s - INSTR will be placed into OUTSTR starting at COLUMN
  1.  ;             using LENGTH characters
  1.  ;         "" - Error (bad input)
  1.  ;
  1.  ;NOTE : This module is based on $$SETSTR^VALM1
  1.  ;
  1.  ;CHECK INPUT
  1.  Q:('$D(INSTR)) ""
  1.  Q:('$D(OUTSTR)) ""
  1.  S:('$D(COLUMN)) COLUMN=$L(OUTSTR)+1
  1.  S:('$D(LENGTH)) LENGTH=$L(INSTR)
  1.  ;DECLARE VARIABLES
  1.  N FRONT,END
  1.  S FRONT=$E((OUTSTR_$J("",COLUMN-1)),1,(COLUMN-1))
  1.  S END=$E(OUTSTR,(COLUMN+LENGTH),$L(OUTSTR))
  1.  ;INSERT STRING
  1.  Q FRONT_$E((INSTR_$J("",LENGTH)),1,LENGTH)_END
  1. TYPE(DFN) ;Determine patient type DBIA #2511
  1.  ;   input 
  1.  ;   DFN = patient ien
  1.  ;
  1.  ;   output
  1.  ;   ECXPTYPE = patient type external value from file 391
  1.  ;
  1.  ;          AC = ACTIVE DUTY        MI = MILITARY RETIREE
  1.  ;          AL = ALLIED VETERAN     NO = NON-VETERAN (OTHER)
  1.  ;          CO = COLLATERAL         NS = NSC VETERAN
  1.  ;          EM = EMPLOYEE           SC = SC VETERAN
  1.  ;          IN = INELIGIBLE         TR = TRICARE
  1.  ;          return value 0 if no data found, 1 if data found
  1.  ;
  1.  N TYPE,ECXPTYPE
  1.  ;Check input
  1.  Q:'$D(DFN) ""
  1.  S (TYPE,ECXPTYPE)=""
  1.  S TYPE=$G(^DPT(DFN,"TYPE"))
  1.  I 'TYPE Q ECXPTYPE
  1.  S ECXPTYPE=$P($G(^DG(391,TYPE,0)),U,1)
  1.  S ECXPTYPE=$E(ECXPTYPE,1,2)
  1.  Q ECXPTYPE
  1. CVEDT(DFN,DATE) ;Determine patient CV status DBIA #4156
  1.  ;   input
  1.  ;   DFN = patient ien
  1.  ;
  1.  ;   output
  1.  ;   ECXCVE = combat veteran status eligibility
  1.  ;   ECXCVEDT = combat veteran eligibility end date
  1.  ;   ECXCVENC = combat veteran encounter
  1.  ;Initialize variables
  1.  N CVSTAT
  1.  S (CVSTAT,ECXCVE,ECXCVEDT,ECXCVENC)=""
  1.  ;Check input
  1.  Q:'$D(DFN) 0
  1.  ;Call CV API
  1.  S CVSTAT=$$CVEDT^DGCV(DFN,DATE)
  1.  I CVSTAT<1 Q 0
  1.  ;Veteran been given CV eligibility
  1.  S ECXCVE=$S($P(CVSTAT,U,3)=1:"Y",$P(CVSTAT,U,3)=0:"E",1:"")
  1.  ;Save CV eligibility end date and convert from FM to HL7 format
  1.  S ECXCVEDT=$P(CVSTAT,U,2)
  1.  S ECXCVEDT=$$FMTHL7^XLFDT(ECXCVEDT)
  1.  ;Is the veteran eligible for CV in the date of encounter
  1.  S ECXCVENC=$S($P(CVSTAT,U,3)=1:"Y",1:"")
  1.  Q 1
  1. NPRF ;National patient record flags DBIA #3860
  1.  N ECXARR,FLG
  1.  S ECXNPRFI="",CNT=$$GETACT^DGPFAPI(ECXDFN,"ECXARR"),FLG=""
  1.  I 'CNT Q
  1.  F I=1:1:CNT D  Q:FLG
  1.  .I ECXARR(I,"CATEGORY")["NATIONAL" S ECXNPRFI="Y",FLG=1
  1.  Q
  1. RXPTST(K) ;Rx patient status DBIA #2511
  1.  N ECXDIC,STAT
  1.  S (ECXDIC,STAT)=""
  1.  ;Check input
  1.  Q:'$D(K) STAT
  1.  S DA=K,DIC="^PS(53,",DIQ(0)="I",DIQ="ECXDIC",DR="6"
  1.  D EN^DIQ1
  1.  S STAT=$G(ECXDIC(53,K,6,"I"))
  1.  S STAT=$S(STAT=1:"SC",STAT=2:"AA",STAT=3:"OTH",STAT=4:"INP",STAT=5:"NON",1:"")
  1.  Q STAT
  1. NONVAP(K) ;Non-va prescriber DBIA #10060
  1.  N ECXDIC,NONVAP
  1.  S (ECXDIC,NONVAP)=""
  1.  Q:'$D(K) NONVAP
  1.  S DA=K,DIC="^VA(200,",DIQ(0)="I",DIQ="ECXDIC",DR="53.91"
  1.  D EN^DIQ1
  1.  S NONVAP=$G(ECXDIC(200,K,53.91,"I"))
  1.  I NONVAP S NONVAP="Y"
  1.  Q NONVAP
  1. DOIVPO(K,L) ;Add destination for outpatient ivp orders
  1.  ;     Input     K - DFN
  1.  ;               L - Order # from Pharmacy Patient File (#55)
  1.  ;
  1.  ;     Output    ordering stop code (clinic has been assigned a valid stop code)
  1.  ;          OR   Clinic^MISSING STOP CODE  
  1.  ;               Clinic^INVALID STOP CODE^Stop Code
  1.  ;
  1.  N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA
  1.  S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)=""
  1.  ;Check input
  1.  Q:'K!'(L) SCODE
  1.  ;Check treating specialty
  1.  S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE
  1.  ;Go to pharmacy patient file (#55) and return value of field (#136)
  1.  S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="100",DR(55.01)="136",DA=K,DA(55.01)=L
  1.  D EN^DIQ1
  1.  S CLINIC=$G(ECXDIC(55.01,L,136,"I"))
  1.  I 'CLINIC Q SCODE
  1.  ;Get stop code pointer to file 40.7 from file 44
  1.  S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1
  1.  S SCODE=$G(ECXDICA(44,CLINIC,8,"I")) ;181 - Add $Get
  1.  I 'SCODE S SCODE=CLINIC_U_"MISSING STOP CODE" Q SCODE  ;181 - Clinic has NO stop code
  1.  ;Get stop code external value
  1.  S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1;2",DA=SCODE D EN^DIQ1 ;181 - Add Inactive Date
  1.  I $G(ECXDICB(40.7,SCODE,2,"E"))'="" S SCODE=CLINIC_U_"INVALID STOP CODE"_U_SCODE Q SCODE  ;181 - Stop Code is Inactive
  1.  S SCODE=$G(ECXDICB(40.7,SCODE,1,"E"))
  1.  Q SCODE
  1.  ;
  1. DOUDO(K,L) ;Add destination for outpatient udp orders
  1.  ;     Input     K - DFN
  1.  ;               L - Order # from Pharmacy Patient File (#55)
  1.  ;
  1.  ;     Output    ordering stop code (clinic has been assigned a valid stop code)
  1.  ;          OR   Clinic^MISSING STOP CODE  
  1.  ;               Clinic^INVALID STOP CODE^Stop Code
  1.  ;
  1.  N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA
  1.  S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)=""
  1.  ;Check treating specialty
  1.  S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE
  1.  ;Check input
  1.  Q:'K!'(L) SCODE
  1.  S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="62",DR(55.06)="130",DA=K,DA(55.06)=L
  1.  D EN^DIQ1
  1.  S CLINIC=$G(ECXDIC(55.06,L,130,"I"))
  1.  I 'CLINIC Q SCODE
  1.  ;Get stop code pointer to file 40.7 from file 44
  1.  S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1
  1.  S SCODE=$G(ECXDICA(44,CLINIC,8,"I")) ;181 - Add $Get
  1.  I 'SCODE S SCODE=CLINIC_U_"MISSING STOP CODE" Q SCODE  ;181 - Clinic has NO stop code
  1.  ;Get stop code external value
  1.  S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1;2",DA=SCODE D EN^DIQ1 ;181 -  Add Inactive Date
  1.  I $G(ECXDICB(40.7,SCODE,2,"E"))'="" S SCODE=CLINIC_U_"INVALID STOP CODE"_U_SCODE Q SCODE  ;181 - Stop Code is Inactive
  1.  S SCODE=$G(ECXDICB(40.7,SCODE,1,"E"))
  1.  Q SCODE
  1.  ;
  1. PHAAPI(DRUG) ;Call Pharmacy drug file API dbia 4483
  1.  ;   Input: drug file (#50) ien
  1.  ;
  1.  ;   Output: generic name ^ classification ^ ndc ^ dea hand
  1.  ;            ^ ndf file entry # ^ psndf va product entry ^
  1.  ;            price per disp unit ^ dispense unit^ Price per Order Unit^ Dispense Unit per Order Unit ;184 added last 2 fields
  1.  ;
  1.  ;
  1.  ;Initialize variables and scratch global
  1.  N NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,UNIT,ARRAY,DATA
  1.  N PPOU,DUPOU ;184
  1.  S (NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,ARRAY,DATA,PPOU,DUPOU)="" ;184 Added Price Per Order Unit, Dispense Unit Per Order Unit
  1.  S ARRAY="^TMP($J,""ECXLIST"")"
  1.  K @ARRAY
  1.  D DATA^PSS50(DRUG,,,,,"ECXLIST")
  1.  I @ARRAY@(0)'>0 Q "^^^^^^"
  1.  S NAME=@ARRAY@(DRUG,.01),CLASS=@ARRAY@(DRUG,2),NDC=@ARRAY@(DRUG,31)
  1.  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)
  1.  S PPOU=@ARRAY@(DRUG,13),DUPOU=@ARRAY@(DRUG,15) ;184 
  1.  I NDC="",P3="" D  ;170,174 If NDC and NDF are blank, assign an LCL or LCD NDC
  1.  .;174, Set NDC to LCL (supply items) or LCD (non-supply items) concatenated with the last 9 digits of IEN if IEN is longer than 9 digits
  1.  .S NDC=$S(INV["S":"LCL",1:"LCD")_$$RJ^XLFSTR($E(DRUG,$S($L(DRUG)'>9:1,1:1+($L(DRUG)-9)),$L(DRUG)),9,0) ;174
  1.  .S NDC=$E(NDC,1,6)_"-"_$E(NDC,7,10)_"-"_$E(NDC,11,12) ;Put NDC in xxxxxx-xxxx-xx format
  1.  K @ARRAY
  1.  Q NAME_U_CLASS_U_NDC_U_INV_U_P1_U_P3_U_PPDU_U_UNIT_U_PPOU_U_DUPOU ;184 Added Price Per Order Unit, Dispense Unit Per Order Unit
  1.  ;
  1. TSSC(X) ;Check treating specialty (ts) and if ts equals any of the following
  1.  ;18,23,24,36,41,65,94,108(1J) then assign predefined code and return value
  1.  ;
  1.  ;    Input: treating specialty
  1.  ;    Output: Ordering stop code
  1.  ;
  1.  S CODE=$S(X=18:293,X=23:295,X=24:290,X=36:294,X=41:296,X=65:291,X=94:292,X=108:297,1:"")
  1.  Q CODE
  1.  ;
  1. PSJ59P5(X) ;Get iv room division
  1.  ;   Input  X - iv room ien
  1.  ;
  1.  ;   Output - field .02 division
  1.  ;Init variables
  1.  N DIV S DIV=""
  1.  ;Check input
  1.  I 'X  Q DIV
  1.  D ALL^PSJ59P5(X,,"ECXDIV")
  1.  S DIV=$P($G(^TMP($J,"ECXDIV",X,.02)),U)
  1.  K ^TMP($J,"ECXDIV")
  1.  Q DIV
  1.  ;
  1. SCRX(IEN) ;Service connected prescription
  1.  ;Init variables
  1.  N DIC,DR,DA,ECXDIQ
  1.  ;Check input
  1.  I '$G(IEN) Q ""
  1.  S DIC=52,DR="116",DA=IEN,DIQ="ECXDIQ"
  1.  D DIQ^PSODI(DIC,DIC,DR,DA,DIQ)
  1.  Q $S($G(ECXDIQ(52,DA,116))="YES":"Y",$G(ECXDIQ(52,DA,116))="NO":"N",1:"")
  1.  ;
  1. SSN(SSN,FILE) ; extended validation of ssn
  1.  ;       input:     ssn - social security number to validate
  1.  ;                  file - optional "", 2 or 67, the only check is for
  1.  ;                         reference lab file (#67) in which case ssn
  1.  ;                         "000123456" is considered a valid ssn.
  1.  ;        output:   0 - test patient or invalid ssn
  1.  ;                  1 - valid ssn
  1.  ;
  1.  ;check input
  1.  I $G(SSN)']"" Q 0
  1.  S FILE=$G(FILE)
  1.  I (FILE=67)&(SSN="000123456") Q 1
  1.  I $L(SSN)=10&($E(SSN,10)="P") Q 1  ;166 Consider pseudo SSNs valid
  1.  I $E(SSN)=9 Q 0  ;170, Added back filtering of SSNs that start with 9
  1.  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
  1.  I SSN="777777777"!(SSN="888888888")!(SSN="999999999") Q 0  ;136 adding new exclusions for the 7, 8, and 9 series where the numbers repeat
  1.  I $E(SSN,6,9)="0000" Q 0  ;170 Added filtering of last 4 being all zeros
  1.  I $TR(SSN,"0123456789")'="" Q 0  ;187 SSN is not all numeric.
  1.  I $L(SSN)'=9 Q 0  ;187 Length of SSN is NOT 9
  1.  Q 1
  1.  ;