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