ECXUTL ;ALB/JAP - Utilities for DSS Extracts ;3/29/24 12:44
;;3.0;DSS EXTRACTS;**1,5,8,84,90,127,144,184,187,190**;Dec 22, 1997;Build 36
;
; Reference to $$IEN2DATA^XUA4A72,$$GET^XUA4A72 in ICR #1625
; Reference to ^DPT( in ICR #1850
; Reference to EN^PSJBCMA1 in ICR #2829
; Reference to ^TMP("PSJ" supported by SACC 2.3.2.5.1
;
ECXYM(ECXFMDT) ;extrinsic function
;converts any FM internal format date or date/time to a 6-character string
;
; input
; ECXFMDT = date or date/time; FM internal format (required)
; output
; ECXYM = YYYYMM string
;
N MONTH,YEAR,CENTURY,ECXYM
;
;error checks
I +ECXFMDT'=ECXFMDT S ECXYM="000000" Q ECXYM
I $L($P(ECXFMDT,"."))'=7 S ECXYM="000000" Q ECXYM
I +$E(ECXFMDT,4,5)<1!(+$E(ECXFMDT,4,5)>12) S ECXYM="000000" Q ECXYM
;
S MONTH=$E(ECXFMDT,4,5),YEAR=$E(ECXFMDT,2,3),CENTURY=$E(ECXFMDT,1)+17
S ECXYM=CENTURY_YEAR_MONTH
Q ECXYM
;
ECXYMX(ECXYM) ;extrinsic function
;converts a 6-character numeric string of format YYYYMM
;to a FM external format date
;
; input
; ECXYM = YYYYMM string (required)
; output
; ECXYMX = FM external format date;
; SEP 1997
; error code
; if input problem, then "000000" returned
;
N Y,%DT,CENTURY,FMCENT,ECXYMX
;
;error checks
I ECXYM="" S ECXYMX="000000" Q ECXYMX
I +ECXYM'=ECXYM S ECXYMX="000000" Q ECXYMX
I $L(ECXYM)'=6 S ECXYMX="000000" Q ECXYMX
I +$E(ECXYM,1,4)<1800 S ECXYMX="000000" Q ECXYMX
I +$E(ECXYM,5,6)<1!(+$E(ECXYM,5,6)>12) S ECXYMX="000000" Q ECXYMX
;
S CENTURY=$E(ECXYM,1,2)
S FMCENT=CENTURY-17
S Y=FMCENT_$E(ECXYM,3,6) D DD^%DT S ECXYMX=Y
;
;error checks
I $L(ECXYMX)'=8 S ECXYMX="000000"
I "JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC"'[$E(ECXYMX,1,3) S ECXYMX="000000"
Q ECXYMX
;
ECXDATE(ECXFMDT,ECXYM) ;extrinsic function
;converts any FM internal format date or date/time to a 8-character string
;
; input
; ECXFMDT = date or date/time; FM internal format (required)
; ECXYM = YYYYMM; year/month 6-character string (required)
; output
; ECXDATE = YYYYMMDD string
; error code
; "000000" returned, if problem with input
;
N MONTH,YEAR,CENTURY,DAY,ECXDATE
;
S ECXFMDT=+ECXFMDT ;187
;error checks
I +ECXYM'=ECXYM S ECXDATE="000000" Q ECXDATE
I $L(ECXYM)'=6 S ECXDATE="000000" Q ECXDATE
I +$E(ECXYM,1,4)<1800 S ECXDATE="000000" Q ECXDATE
I +$E(ECXYM,5,6)<1!($E(ECXYM,5,6)>12) S ECXDATE="000000" Q ECXDATE
;special case where ecxfmdt is null; default to year/month of ecxym
I ECXFMDT="" S ECXDATE=ECXYM_"01" Q ECXDATE
;error checks
I +ECXFMDT'=ECXFMDT S ECXDATE=ECXYM_"01" Q ECXDATE
I $L(ECXFMDT)<7 S ECXDATE=ECXYM_"01" Q ECXDATE
I +$E(ECXFMDT,4,5)>12 S ECXDATE=ECXYM_"01" Q ECXDATE
I +$E(ECXFMDT,6,7)>31 S ECXFMDT=$E(ECXFMDT,1,5)_"01"
;default to 1st day of month
S DAY=$E(ECXFMDT,6,7) S:DAY="00" DAY="01"
;default to month of ecxym
S MONTH=$E(ECXFMDT,4,5) S:MONTH="00" MONTH=$E(ECXYM,5,6)
S YEAR=$E(ECXFMDT,2,3)
S CENTURY=$E(ECXFMDT,1)+17
S ECXDATE=CENTURY_YEAR_MONTH_DAY
Q ECXDATE
;
ECXDATEX(ECXDATE) ;extrinsic function
;converts an 8-character numeric string of format YYYYMMDD
;to a FM external format date
;
; input
; ECXDATE = YYYYMMDD string (required)
; output
; ECXDATEX = FM external format date;
; SEP 12, 1997
; error code
; if input problem, then "000000" returned
;
N Y,%DT,CENTURY,FMCENT,ECXDATEX
;
;error checks
I +ECXDATE'=ECXDATE S ECXDATEX="000000" Q ECXDATEX
I $L(ECXDATE)'=8 S ECXDATEX="000000" Q ECXDATEX
I +$E(ECXDATE,7,8)>31 S ECXDATEX="000000" Q ECXDATEX
;
S CENTURY=$E(ECXDATE,1,2)
S FMCENT=CENTURY-17
S Y=FMCENT_$E(ECXDATE,3,8) D DD^%DT S ECXDATEX=Y
;
;error checks
I $L(ECXDATEX)'=12 S ECXDATEX="000000"
I "JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC"'[$E(ECXDATEX,1,3) S ECXDATEX="000000"
Q ECXDATEX
;
ECXDOB(ECXFMDT) ;extrinsic function
;converts a FM internal format date or date/time to a 6-character string
;if ecxfmdt is null, the function returns 19420101
; input
; ECXFMDT = date or date/time (required);
; must be valid FM internal format
; output
; ECXDOB = YYYYMMDD string (required);
; defaults to 19420101
;
N MONTH,YEAR,CENTURY,DAY,ECXDOB
;only consider date portion
S ECXFMDT=$P(ECXFMDT,".",1)
;special case where ecxfmdt is null
I ECXFMDT="" S ECXDOB="17760704" Q ECXDOB
;error checks - return default 144 - change def from 19420101 to 17760704
I +ECXFMDT'=ECXFMDT S ECXDOB="17760704" Q ECXDOB
I $L(ECXFMDT)<7 S ECXDOB="17760704" Q ECXDOB
I +ECXFMDT>DT S ECXDOB="17760704" Q ECXDOB
;default to 1st day of month
S DAY=$E(ECXFMDT,6,7) S:DAY="00"!(+DAY>31) DAY="01"
;default to 1st month of year
S MONTH=$E(ECXFMDT,4,5) S:MONTH="00"!(+MONTH>12) MONTH="01",DAY="01"
S YEAR=$E(ECXFMDT,2,3)
S CENTURY=$E(ECXFMDT,1)+17
S ECXDOB=CENTURY_YEAR_MONTH_DAY
Q ECXDOB
;
ECXTIME(ECXFMDT) ;extrinsic function
;converts Fileman internal date/time to 6-character time string
;format HHMMSS
;
; input
; ECXFMDT = date or date/time (required);
; must be valid FM internal format
; output
; ECXTIME = 6-character numeric string;
; format HHMMSS; string length always 6
;
N J,JJ,TIME,HH,MM,SS,ECXTIME
;if any non-numerics, set default
I +ECXFMDT=0 S ECXTIME="000300" Q ECXTIME
;use only time portion of fileman internal format
S TIME=$P(ECXFMDT,".",2),TIME=$E(TIME,1,6)
;if time unknown, set default
I TIME="" S ECXTIME="000300" Q ECXTIME
;be sure time is 6 characters
S TIME=$$LJ^XLFSTR(TIME,6,0)
;error checks -- set default
S HH=$E(TIME,1,2),MM=$E(TIME,3,4),SS=$E(TIME,5,6)
I +HH>23 S ECXTIME="000300" Q ECXTIME
I +MM>59 S MM="59"
I +SS>59 S SS="59"
S ECXTIME=HH_MM_SS
Q ECXTIME
;
ECXTIMEX(ECXTIME,ECXMIL) ;extrinsic function
;converts a 6-character time string to external, user readable format
;used as output transform for time fields in many dss extract files
; input
; ECXTIME = 6-character numeric string (required);
; ECXMIL = if "1", then return military time (optional)
; output
; ECXTIMEX = character string;
; if ECXMIL=1, format HH:MM:SS
; otherwise, hours:mins AM/PM
; error code
; if input problem, then "000000" returned
;
N TIME,HH,MM,SS,ECXTIMEX,J,JJ
;error checks
I $L(ECXTIME)'=6 S ECXTIMEX="000000" Q ECXTIMEX
F J=1:1:6 S JJ=$E(ECXTIME,J) I $A(JJ)<48!($A(JJ)>57) S ECXTIMEX="000000" Q
I $D(ECXTIMEX) Q ECXTIMEX
S HH=$E(ECXTIME,1,2),MM=$E(ECXTIME,3,4),SS=$E(ECXTIME,5,6)
I +HH>23!(+MM>59)!(+SS>59) S ECXTIMEX="000000" Q ECXTIMEX
;if ecxmil=1, return military time
I $G(ECXMIL) S ECXTIMEX=HH_":"_MM_":"_SS Q ECXTIMEX
;otherwise, use am/pm format
S X="0."_ECXTIME
S X=$E($P(X,".",2)_"0000",1,4),%=X>1159 S:X>1259 X=X-1200
S X=X\100_":"_$E(X#100+100,2,3)_" "_$E("AP",%+1)_"M"
S ECXTIMEX=X
Q ECXTIMEX
;
AOIRPOW(ECXDFN,ECXAIP) ;get data on ao, ir, pow status
;
; input
; ECXDFN = ien in file #2 (required)
; ECXAIP = array for returned data (required)
; (passed by reference)
;
; output
; ECXAIP("AO") = agent orange status
; ECXAIP("IR") = ion. radiation status
; ECXAIP("POW") = pow status
; ECXAIP("POWL") = pow location/period
;
N J
S ECXAIP("AO")="",ECXAIP("IR")="",ECXAIP("POW")="",ECXAIP("POWL")=""
S ECXAIP("AO")=$P($G(^DPT(ECXDFN,.321)),U,2),ECXAIP("IR")=$P($G(^(.321)),U,3)
S ECXAIP("POW")=$P($G(^DPT(ECXDFN,.52)),U,5),ECXAIP("POWL")=$P($G(^(.52)),U,6)
F J="AO","IR","POW" I ECXAIP(J)="" S ECXAIP(J)="U"
I ECXAIP("POWL"),ECXAIP("POW")'="Y" S ECXAIP("POWL")=""
Q
;
PRVCLASS(PERS,DATE) ;determine the person class and return va code
; input
; PERS = pointer to file #200 (required)
; DATE = date on which person class must be active (required)
; (internal Fileman format)
; output
; VACODE = VA code field from file #8932.1
; (exactly 7 characters in length)
N ECX,VACODE
S VACODE=""
S ECHEAD=$G(ECHEAD)
S ECX=$$GET^XUA4A72(PERS,DATE)
;if no person class use alternate date to resolve person class
I +ECX'>0 D
.N DATE
.S DATE=$S(ECHEAD="LAB":$P(EC1,U,14),ECHEAD="LAR":$P(EC1,U,4),ECHEAD="PRE":$P(ECDATA,U,13),ECHEAD="RAD":$P($G(^RAO(75.1,+$G(ECXIEN),0)),U,16),1:"")
.S ECX=$$GET^XUA4A72(PERS,DATE)
.Q
S VACODE=$P(ECX,U,7) I $L(VACODE)'=7 S VACODE=""
Q VACODE
;
PATCAT(DFN) ; Extrinsic function to return OTHER ELIGIBILITY CODE
; in patcat field in the extract file if the PATIENT TYPE
; = active duty, retire, tricare
; INPUT DFN - ien in file #2 (required)
; OUTPUT PATCAT - Patient Category mapping to be filed in extracts
;
N ELIG,I,PATCAT,PCAT,TYPE
S PATCAT=""
I '$G(DFN) Q PATCAT
S TYPE=$$TYPE^ECXUTL5(DFN)
I (TYPE="MI")!(TYPE="AC")!(TYPE="TR") D
.;get first other eligibilty code that matches in list, if it exists
.S ELIG=0 F S ELIG=$O(^DPT(DFN,"E",ELIG)) Q:(ELIG'>0)!((ELIG>0)&(PATCAT'="")) D
..; if get last code, use line below
..;S ELIG=0 F S ELIG=$O(^DPT(DFN,"E",ELIG)) Q:(ELIG'>0) D
..S PCAT=$$GET1^DIQ(8,ELIG,.01)
..F I=1:1 Q:$T(ELIGCDS+I)=" Q" I PCAT=$P($T(ELIGCDS+I),";;",2) S PATCAT=$P($T(ELIGCDS+I),";;",3)
Q PATCAT
;
ORDPROV(DFN,ON,PSJTMP) ; get provider using order reference number
; input:
; dfn
; on - order reference number
; psjtmp - 1 if temp global node = PSJ1, else global node = PSJ
;
; output:
; Provider IEN from PARMACY PATIENT File (#55) (1st piece ^TMP( )
;
; NOTE: Don't kill ^TMP here, used in ECXBCM, killed there
;
I $G(DFN)']"" Q 0
I $G(ON)']"" Q 0
D EN^PSJBCMA1(DFN,ON,PSJTMP) ;IA#2829
Q +($G(^TMP("PSJ",$J,1)))
;
PRVX12(PERS,DATE) ;184 - Provider Taxonomy
; input
; PERS = pointer to file #200 (required)
; DATE = date on which person class must be active (required)
; (internal Fileman format)
; output
; X12CODE = X12 code field from file #8932.1
; (exactly 7 characters in length)
N ECX,X12CODE
S X12CODE=""
S ECHEAD=$G(ECHEAD)
S ECX=$$GET^XUA4A72(PERS,DATE)
;if no person class use alternate date to resolve person class
I +ECX'>0 D
.N DATE
.S DATE=$S(ECHEAD="LAB":$P(EC1,U,14),ECHEAD="LAR":$P(EC1,U,4),ECHEAD="PRE":$P(ECDATA,U,13),ECHEAD="RAD":$P($G(^RAO(75.1,+$G(ECXIEN),0)),U,16),1:"")
.S ECX=$$GET^XUA4A72(PERS,DATE)
.Q
S X12CODE=$P($$IEN2DATA^XUA4A72(+ECX),U,7)
Q X12CODE
ELIGCDS ;
;;AD-ACTIVE DUTY;;AD
;;REC-RECRUIT;;REC
;;ADD-ACTIVE DUTY DEPENDENT;;ADD
;;FNRS-NON REMARRIED SPOUSE;;FNRS
;;RET-RETIREE;;RET
;;RETD-RETIREE DEPENDENT;;RETD
;;RES-RESERVIST;;RES
;;TFL-TRICARE FOR LIFE;;TFL
;;TDRL-TEMPORARY DISABILITY;;TDRL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXUTL 10864 printed Dec 13, 2024@01:54:22 Page 2
ECXUTL ;ALB/JAP - Utilities for DSS Extracts ;3/29/24 12:44
+1 ;;3.0;DSS EXTRACTS;**1,5,8,84,90,127,144,184,187,190**;Dec 22, 1997;Build 36
+2 ;
+3 ; Reference to $$IEN2DATA^XUA4A72,$$GET^XUA4A72 in ICR #1625
+4 ; Reference to ^DPT( in ICR #1850
+5 ; Reference to EN^PSJBCMA1 in ICR #2829
+6 ; Reference to ^TMP("PSJ" supported by SACC 2.3.2.5.1
+7 ;
ECXYM(ECXFMDT) ;extrinsic function
+1 ;converts any FM internal format date or date/time to a 6-character string
+2 ;
+3 ; input
+4 ; ECXFMDT = date or date/time; FM internal format (required)
+5 ; output
+6 ; ECXYM = YYYYMM string
+7 ;
+8 NEW MONTH,YEAR,CENTURY,ECXYM
+9 ;
+10 ;error checks
+11 IF +ECXFMDT'=ECXFMDT
SET ECXYM="000000"
QUIT ECXYM
+12 IF $LENGTH($PIECE(ECXFMDT,"."))'=7
SET ECXYM="000000"
QUIT ECXYM
+13 IF +$EXTRACT(ECXFMDT,4,5)<1!(+$EXTRACT(ECXFMDT,4,5)>12)
SET ECXYM="000000"
QUIT ECXYM
+14 ;
+15 SET MONTH=$EXTRACT(ECXFMDT,4,5)
SET YEAR=$EXTRACT(ECXFMDT,2,3)
SET CENTURY=$EXTRACT(ECXFMDT,1)+17
+16 SET ECXYM=CENTURY_YEAR_MONTH
+17 QUIT ECXYM
+18 ;
ECXYMX(ECXYM) ;extrinsic function
+1 ;converts a 6-character numeric string of format YYYYMM
+2 ;to a FM external format date
+3 ;
+4 ; input
+5 ; ECXYM = YYYYMM string (required)
+6 ; output
+7 ; ECXYMX = FM external format date;
+8 ; SEP 1997
+9 ; error code
+10 ; if input problem, then "000000" returned
+11 ;
+12 NEW Y,%DT,CENTURY,FMCENT,ECXYMX
+13 ;
+14 ;error checks
+15 IF ECXYM=""
SET ECXYMX="000000"
QUIT ECXYMX
+16 IF +ECXYM'=ECXYM
SET ECXYMX="000000"
QUIT ECXYMX
+17 IF $LENGTH(ECXYM)'=6
SET ECXYMX="000000"
QUIT ECXYMX
+18 IF +$EXTRACT(ECXYM,1,4)<1800
SET ECXYMX="000000"
QUIT ECXYMX
+19 IF +$EXTRACT(ECXYM,5,6)<1!(+$EXTRACT(ECXYM,5,6)>12)
SET ECXYMX="000000"
QUIT ECXYMX
+20 ;
+21 SET CENTURY=$EXTRACT(ECXYM,1,2)
+22 SET FMCENT=CENTURY-17
+23 SET Y=FMCENT_$EXTRACT(ECXYM,3,6)
DO DD^%DT
SET ECXYMX=Y
+24 ;
+25 ;error checks
+26 IF $LENGTH(ECXYMX)'=8
SET ECXYMX="000000"
+27 IF "JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC"'[$EXTRACT(ECXYMX,1,3)
SET ECXYMX="000000"
+28 QUIT ECXYMX
+29 ;
ECXDATE(ECXFMDT,ECXYM) ;extrinsic function
+1 ;converts any FM internal format date or date/time to a 8-character string
+2 ;
+3 ; input
+4 ; ECXFMDT = date or date/time; FM internal format (required)
+5 ; ECXYM = YYYYMM; year/month 6-character string (required)
+6 ; output
+7 ; ECXDATE = YYYYMMDD string
+8 ; error code
+9 ; "000000" returned, if problem with input
+10 ;
+11 NEW MONTH,YEAR,CENTURY,DAY,ECXDATE
+12 ;
+13 ;187
SET ECXFMDT=+ECXFMDT
+14 ;error checks
+15 IF +ECXYM'=ECXYM
SET ECXDATE="000000"
QUIT ECXDATE
+16 IF $LENGTH(ECXYM)'=6
SET ECXDATE="000000"
QUIT ECXDATE
+17 IF +$EXTRACT(ECXYM,1,4)<1800
SET ECXDATE="000000"
QUIT ECXDATE
+18 IF +$EXTRACT(ECXYM,5,6)<1!($EXTRACT(ECXYM,5,6)>12)
SET ECXDATE="000000"
QUIT ECXDATE
+19 ;special case where ecxfmdt is null; default to year/month of ecxym
+20 IF ECXFMDT=""
SET ECXDATE=ECXYM_"01"
QUIT ECXDATE
+21 ;error checks
+22 IF +ECXFMDT'=ECXFMDT
SET ECXDATE=ECXYM_"01"
QUIT ECXDATE
+23 IF $LENGTH(ECXFMDT)<7
SET ECXDATE=ECXYM_"01"
QUIT ECXDATE
+24 IF +$EXTRACT(ECXFMDT,4,5)>12
SET ECXDATE=ECXYM_"01"
QUIT ECXDATE
+25 IF +$EXTRACT(ECXFMDT,6,7)>31
SET ECXFMDT=$EXTRACT(ECXFMDT,1,5)_"01"
+26 ;default to 1st day of month
+27 SET DAY=$EXTRACT(ECXFMDT,6,7)
if DAY="00"
SET DAY="01"
+28 ;default to month of ecxym
+29 SET MONTH=$EXTRACT(ECXFMDT,4,5)
if MONTH="00"
SET MONTH=$EXTRACT(ECXYM,5,6)
+30 SET YEAR=$EXTRACT(ECXFMDT,2,3)
+31 SET CENTURY=$EXTRACT(ECXFMDT,1)+17
+32 SET ECXDATE=CENTURY_YEAR_MONTH_DAY
+33 QUIT ECXDATE
+34 ;
ECXDATEX(ECXDATE) ;extrinsic function
+1 ;converts an 8-character numeric string of format YYYYMMDD
+2 ;to a FM external format date
+3 ;
+4 ; input
+5 ; ECXDATE = YYYYMMDD string (required)
+6 ; output
+7 ; ECXDATEX = FM external format date;
+8 ; SEP 12, 1997
+9 ; error code
+10 ; if input problem, then "000000" returned
+11 ;
+12 NEW Y,%DT,CENTURY,FMCENT,ECXDATEX
+13 ;
+14 ;error checks
+15 IF +ECXDATE'=ECXDATE
SET ECXDATEX="000000"
QUIT ECXDATEX
+16 IF $LENGTH(ECXDATE)'=8
SET ECXDATEX="000000"
QUIT ECXDATEX
+17 IF +$EXTRACT(ECXDATE,7,8)>31
SET ECXDATEX="000000"
QUIT ECXDATEX
+18 ;
+19 SET CENTURY=$EXTRACT(ECXDATE,1,2)
+20 SET FMCENT=CENTURY-17
+21 SET Y=FMCENT_$EXTRACT(ECXDATE,3,8)
DO DD^%DT
SET ECXDATEX=Y
+22 ;
+23 ;error checks
+24 IF $LENGTH(ECXDATEX)'=12
SET ECXDATEX="000000"
+25 IF "JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC"'[$EXTRACT(ECXDATEX,1,3)
SET ECXDATEX="000000"
+26 QUIT ECXDATEX
+27 ;
ECXDOB(ECXFMDT) ;extrinsic function
+1 ;converts a FM internal format date or date/time to a 6-character string
+2 ;if ecxfmdt is null, the function returns 19420101
+3 ; input
+4 ; ECXFMDT = date or date/time (required);
+5 ; must be valid FM internal format
+6 ; output
+7 ; ECXDOB = YYYYMMDD string (required);
+8 ; defaults to 19420101
+9 ;
+10 NEW MONTH,YEAR,CENTURY,DAY,ECXDOB
+11 ;only consider date portion
+12 SET ECXFMDT=$PIECE(ECXFMDT,".",1)
+13 ;special case where ecxfmdt is null
+14 IF ECXFMDT=""
SET ECXDOB="17760704"
QUIT ECXDOB
+15 ;error checks - return default 144 - change def from 19420101 to 17760704
+16 IF +ECXFMDT'=ECXFMDT
SET ECXDOB="17760704"
QUIT ECXDOB
+17 IF $LENGTH(ECXFMDT)<7
SET ECXDOB="17760704"
QUIT ECXDOB
+18 IF +ECXFMDT>DT
SET ECXDOB="17760704"
QUIT ECXDOB
+19 ;default to 1st day of month
+20 SET DAY=$EXTRACT(ECXFMDT,6,7)
if DAY="00"!(+DAY>31)
SET DAY="01"
+21 ;default to 1st month of year
+22 SET MONTH=$EXTRACT(ECXFMDT,4,5)
if MONTH="00"!(+MONTH>12)
SET MONTH="01"
SET DAY="01"
+23 SET YEAR=$EXTRACT(ECXFMDT,2,3)
+24 SET CENTURY=$EXTRACT(ECXFMDT,1)+17
+25 SET ECXDOB=CENTURY_YEAR_MONTH_DAY
+26 QUIT ECXDOB
+27 ;
ECXTIME(ECXFMDT) ;extrinsic function
+1 ;converts Fileman internal date/time to 6-character time string
+2 ;format HHMMSS
+3 ;
+4 ; input
+5 ; ECXFMDT = date or date/time (required);
+6 ; must be valid FM internal format
+7 ; output
+8 ; ECXTIME = 6-character numeric string;
+9 ; format HHMMSS; string length always 6
+10 ;
+11 NEW J,JJ,TIME,HH,MM,SS,ECXTIME
+12 ;if any non-numerics, set default
+13 IF +ECXFMDT=0
SET ECXTIME="000300"
QUIT ECXTIME
+14 ;use only time portion of fileman internal format
+15 SET TIME=$PIECE(ECXFMDT,".",2)
SET TIME=$EXTRACT(TIME,1,6)
+16 ;if time unknown, set default
+17 IF TIME=""
SET ECXTIME="000300"
QUIT ECXTIME
+18 ;be sure time is 6 characters
+19 SET TIME=$$LJ^XLFSTR(TIME,6,0)
+20 ;error checks -- set default
+21 SET HH=$EXTRACT(TIME,1,2)
SET MM=$EXTRACT(TIME,3,4)
SET SS=$EXTRACT(TIME,5,6)
+22 IF +HH>23
SET ECXTIME="000300"
QUIT ECXTIME
+23 IF +MM>59
SET MM="59"
+24 IF +SS>59
SET SS="59"
+25 SET ECXTIME=HH_MM_SS
+26 QUIT ECXTIME
+27 ;
ECXTIMEX(ECXTIME,ECXMIL) ;extrinsic function
+1 ;converts a 6-character time string to external, user readable format
+2 ;used as output transform for time fields in many dss extract files
+3 ; input
+4 ; ECXTIME = 6-character numeric string (required);
+5 ; ECXMIL = if "1", then return military time (optional)
+6 ; output
+7 ; ECXTIMEX = character string;
+8 ; if ECXMIL=1, format HH:MM:SS
+9 ; otherwise, hours:mins AM/PM
+10 ; error code
+11 ; if input problem, then "000000" returned
+12 ;
+13 NEW TIME,HH,MM,SS,ECXTIMEX,J,JJ
+14 ;error checks
+15 IF $LENGTH(ECXTIME)'=6
SET ECXTIMEX="000000"
QUIT ECXTIMEX
+16 FOR J=1:1:6
SET JJ=$EXTRACT(ECXTIME,J)
IF $ASCII(JJ)<48!($ASCII(JJ)>57)
SET ECXTIMEX="000000"
QUIT
+17 IF $DATA(ECXTIMEX)
QUIT ECXTIMEX
+18 SET HH=$EXTRACT(ECXTIME,1,2)
SET MM=$EXTRACT(ECXTIME,3,4)
SET SS=$EXTRACT(ECXTIME,5,6)
+19 IF +HH>23!(+MM>59)!(+SS>59)
SET ECXTIMEX="000000"
QUIT ECXTIMEX
+20 ;if ecxmil=1, return military time
+21 IF $GET(ECXMIL)
SET ECXTIMEX=HH_":"_MM_":"_SS
QUIT ECXTIMEX
+22 ;otherwise, use am/pm format
+23 SET X="0."_ECXTIME
+24 SET X=$EXTRACT($PIECE(X,".",2)_"0000",1,4)
SET %=X>1159
if X>1259
SET X=X-1200
+25 SET X=X\100_":"_$EXTRACT(X#100+100,2,3)_" "_$EXTRACT("AP",%+1)_"M"
+26 SET ECXTIMEX=X
+27 QUIT ECXTIMEX
+28 ;
AOIRPOW(ECXDFN,ECXAIP) ;get data on ao, ir, pow status
+1 ;
+2 ; input
+3 ; ECXDFN = ien in file #2 (required)
+4 ; ECXAIP = array for returned data (required)
+5 ; (passed by reference)
+6 ;
+7 ; output
+8 ; ECXAIP("AO") = agent orange status
+9 ; ECXAIP("IR") = ion. radiation status
+10 ; ECXAIP("POW") = pow status
+11 ; ECXAIP("POWL") = pow location/period
+12 ;
+13 NEW J
+14 SET ECXAIP("AO")=""
SET ECXAIP("IR")=""
SET ECXAIP("POW")=""
SET ECXAIP("POWL")=""
+15 SET ECXAIP("AO")=$PIECE($GET(^DPT(ECXDFN,.321)),U,2)
SET ECXAIP("IR")=$PIECE($GET(^(.321)),U,3)
+16 SET ECXAIP("POW")=$PIECE($GET(^DPT(ECXDFN,.52)),U,5)
SET ECXAIP("POWL")=$PIECE($GET(^(.52)),U,6)
+17 FOR J="AO","IR","POW"
IF ECXAIP(J)=""
SET ECXAIP(J)="U"
+18 IF ECXAIP("POWL")
IF ECXAIP("POW")'="Y"
SET ECXAIP("POWL")=""
+19 QUIT
+20 ;
PRVCLASS(PERS,DATE) ;determine the person class and return va code
+1 ; input
+2 ; PERS = pointer to file #200 (required)
+3 ; DATE = date on which person class must be active (required)
+4 ; (internal Fileman format)
+5 ; output
+6 ; VACODE = VA code field from file #8932.1
+7 ; (exactly 7 characters in length)
+8 NEW ECX,VACODE
+9 SET VACODE=""
+10 SET ECHEAD=$GET(ECHEAD)
+11 SET ECX=$$GET^XUA4A72(PERS,DATE)
+12 ;if no person class use alternate date to resolve person class
+13 IF +ECX'>0
Begin DoDot:1
+14 NEW DATE
+15 SET DATE=$SELECT(ECHEAD="LAB":$PIECE(EC1,U,14),ECHEAD="LAR":$PIECE(EC1,U,4),ECHEAD="PRE":$PIECE(ECDATA,U,13),ECHEAD="RAD":$PIECE($GET(^RAO(75.1,+$GET(ECXIEN),0)),U,16),1:"")
+16 SET ECX=$$GET^XUA4A72(PERS,DATE)
+17 QUIT
End DoDot:1
+18 SET VACODE=$PIECE(ECX,U,7)
IF $LENGTH(VACODE)'=7
SET VACODE=""
+19 QUIT VACODE
+20 ;
PATCAT(DFN) ; Extrinsic function to return OTHER ELIGIBILITY CODE
+1 ; in patcat field in the extract file if the PATIENT TYPE
+2 ; = active duty, retire, tricare
+3 ; INPUT DFN - ien in file #2 (required)
+4 ; OUTPUT PATCAT - Patient Category mapping to be filed in extracts
+5 ;
+6 NEW ELIG,I,PATCAT,PCAT,TYPE
+7 SET PATCAT=""
+8 IF '$GET(DFN)
QUIT PATCAT
+9 SET TYPE=$$TYPE^ECXUTL5(DFN)
+10 IF (TYPE="MI")!(TYPE="AC")!(TYPE="TR")
Begin DoDot:1
+11 ;get first other eligibilty code that matches in list, if it exists
+12 SET ELIG=0
FOR
SET ELIG=$ORDER(^DPT(DFN,"E",ELIG))
if (ELIG'>0)!((ELIG>0)&(PATCAT'=""))
QUIT
Begin DoDot:2
+13 ; if get last code, use line below
+14 ;S ELIG=0 F S ELIG=$O(^DPT(DFN,"E",ELIG)) Q:(ELIG'>0) D
+15 SET PCAT=$$GET1^DIQ(8,ELIG,.01)
+16 FOR I=1:1
if $TEXT(ELIGCDS+I)=" Q"
QUIT
IF PCAT=$PIECE($TEXT(ELIGCDS+I),";;",2)
SET PATCAT=$PIECE($TEXT(ELIGCDS+I),";;",3)
End DoDot:2
End DoDot:1
+17 QUIT PATCAT
+18 ;
ORDPROV(DFN,ON,PSJTMP) ; get provider using order reference number
+1 ; input:
+2 ; dfn
+3 ; on - order reference number
+4 ; psjtmp - 1 if temp global node = PSJ1, else global node = PSJ
+5 ;
+6 ; output:
+7 ; Provider IEN from PARMACY PATIENT File (#55) (1st piece ^TMP( )
+8 ;
+9 ; NOTE: Don't kill ^TMP here, used in ECXBCM, killed there
+10 ;
+11 IF $GET(DFN)']""
QUIT 0
+12 IF $GET(ON)']""
QUIT 0
+13 ;IA#2829
DO EN^PSJBCMA1(DFN,ON,PSJTMP)
+14 QUIT +($GET(^TMP("PSJ",$JOB,1)))
+15 ;
PRVX12(PERS,DATE) ;184 - Provider Taxonomy
+1 ; input
+2 ; PERS = pointer to file #200 (required)
+3 ; DATE = date on which person class must be active (required)
+4 ; (internal Fileman format)
+5 ; output
+6 ; X12CODE = X12 code field from file #8932.1
+7 ; (exactly 7 characters in length)
+8 NEW ECX,X12CODE
+9 SET X12CODE=""
+10 SET ECHEAD=$GET(ECHEAD)
+11 SET ECX=$$GET^XUA4A72(PERS,DATE)
+12 ;if no person class use alternate date to resolve person class
+13 IF +ECX'>0
Begin DoDot:1
+14 NEW DATE
+15 SET DATE=$SELECT(ECHEAD="LAB":$PIECE(EC1,U,14),ECHEAD="LAR":$PIECE(EC1,U,4),ECHEAD="PRE":$PIECE(ECDATA,U,13),ECHEAD="RAD":$PIECE($GET(^RAO(75.1,+$GET(ECXIEN),0)),U,16),1:"")
+16 SET ECX=$$GET^XUA4A72(PERS,DATE)
+17 QUIT
End DoDot:1
+18 SET X12CODE=$PIECE($$IEN2DATA^XUA4A72(+ECX),U,7)
+19 QUIT X12CODE
ELIGCDS ;
+1 ;;AD-ACTIVE DUTY;;AD
+2 ;;REC-RECRUIT;;REC
+3 ;;ADD-ACTIVE DUTY DEPENDENT;;ADD
+4 ;;FNRS-NON REMARRIED SPOUSE;;FNRS
+5 ;;RET-RETIREE;;RET
+6 ;;RETD-RETIREE DEPENDENT;;RETD
+7 ;;RES-RESERVIST;;RES
+8 ;;TFL-TRICARE FOR LIFE;;TFL
+9 ;;TDRL-TEMPORARY DISABILITY;;TDRL
+10 QUIT
