BPSOSU1 ;BHAM ISC/FCS/DRS/FLS/DLF - copied for ECME ;03/07/08 10:34
;;1.0;E CLAIMS MGMT ENGINE;**1,7**;JUN 2004;Build 46
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;----------------------------------------------------------------------
;Standard Date Functions
;----------------------------------------------------------------------
;Standard Date PROMPT:
;
;Parameters:
; PROMPT = Text to be displayed before read
; DFLT = Default date (internal format)
; OPT = 1 - Answer optional 0 - Answer required
; SDATE = Minimum date (internal format or NOW and DT)
; EDATE = Maximum date (internal format or NOW and DT)
; %DT = E - Echo answer R - Require time
; S - Seconds returned T - Time allowed but not req
; X - Exact date req
; TIMEOUT = Number of seconds
;
;Returns:
; <null> = No response <^> - Up-arrow entered
; <-1> = Timeout occurred <^^> - Two up-arrows entered
; <date> = Internal FM Date
;----------------------------------------------------------------------
; IHS/SD/lwj 8/5/02 NCPDP 5.1 changes
; Subroutine FM3EXT cloned from FM2EXT - routine used to transfer
; the dates. Now that NCPDP 5.1 stores the field ID with all the
; fields, we needed currently just want to skip transforming the
; date for 5.1 type claims
;
;
;----------------------------------------------------------------------
DATE(PROMPT,DFLT,OPT,SDATE,EDATE,%DT,TIMEOUT) ;EP -
;
N XDATA,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
;
Q:$G(PROMPT)="" ""
;
S $P(DIR(0),"^",1)="DA"_$S(OPT=1:"O",1:"")
S $P(XDATA,":",1)=SDATE
S $P(XDATA,":",2)=EDATE
S $P(XDATA,":",3)=%DT
S $P(DIR(0),"^",2)=XDATA
S DIR("A")=PROMPT
S:$G(DFLT)'="" DIR("B")=$$FM2EXT(DFLT)
S:+$G(TIMEOUT)>0 DIR("T")=TIMEOUT
D ^DIR
Q $S($G(DTOUT)=1:-1,$G(DIROUT)=1:"^^",$G(DUOUT)=1:"^",1:Y)
;----------------------------------------------------------------------
;Convert FileMan Date to External Date Format
;
;Parameters: Y - FileMan formatted date (YYYMMDD.HHMMSS)
;Returns: Y - External date
;----------------------------------------------------------------------
FM2EXT(Y) ;EP
Q:$G(^DD("DD"))="" ""
X ^DD("DD")
Q $S($E(Y,1,3)?3A:Y,1:"")
;----------------------------------------------------------------------
;
FM3EXT(Y) ;EP IHS/SD/lwj 8/5/02 clone of FM2EXT- accommodates 5.1 type clms
Q:$E(Y,1,1)["C" Y
S Y=Y-17000000
Q:$G(^DD("DD"))="" ""
X ^DD("DD")
Q $S($E(Y,1,3)?3A:Y,1:"")
;----------------------------------------------------------------------
;
FM2MDY(Y) ;EP
Q:Y="" ""
Q $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
;----------------------------------------------------------------------
;Convert External Date to FileMan Date Format
;
;Parameters: X - External date
;Returns: Y - FileMan formatted date (YYYMMDD.HHMMSS)
;----------------------------------------------------------------------
EXT2FM(X) ;
N %DT,Y
Q:$G(X)="" ""
D ^%DT
Q Y
;----------------------------------------------------------------------
;Returns current Date/Time in FileMan date format
NOWFM() ;EP
N %,%H,%I,X
D NOW^%DTC
Q %
NOWEXT() ;EP - External form of $$NOWFM
N Y S Y=$$NOWFM X ^DD("DD") Q Y
;----------------------------------------------------------------------
;Takes a FileMan date and adds or subtracts days
;
;Parameters: X1 - FileMan formatted date
; X2 - Number of days (ECME = add, neg = subtract)
;Returns: X - Resulting FileMan formatted date
;----------------------------------------------------------------------
CDTFM(X1,X2) ;EP - BPSER*,BPSES02
N X,%H
Q:$G(X1)="" ""
Q:$G(X2)="" ""
D C^%DTC
Q X
;----------------------------------------------------------------------
;Takes a FileMan date and returns 3-digit julian date
JULDATE(DT) ;
N X,X1,X2,%H,%T,%Y
Q:'(DT?7N) ""
S X2=$E(DT,1,3)_"0101",X1=DT
D ^%DTC
S X=X+1
Q $TR($J(X,3)," ","0")
;----------------------------------------------------------------------
;
;$$DTR(AA,AB,ADEF,BDEF,T) Input Beginning & Ending prompts, return
; "Begin date^End date" or 0 if unsuccessful.
;$$DTR() is okay - all args are optional
;$$DTP(AA,DEF) Input a prompt, return a single date "Internal^External"
;$$DTM(AA,DEF) Input a prompt, return month/year "Internal^External"
;--------------------------------------------------------------------
;
DTR(AA,AB,ADEF,BDEF,T) ;EP - GET THE DATE RANGE (beginning and ending dates)
; IN:
; AA = PROMPT for BEGINNING DATE
; AB = PROMPT for ENDING DATE
; ADEF = DEFAULT date for BEGINNING DATE
; BDEF = DEFAULT date for ENDING DATE
; T = whether TIME is allowed as entry, and if REQUIRED
; (If T="T" then TIME is allowed; is REQ'd if T="R").
; OUT:
; Beginning Date^Ending Date in 7digit FileMan format
; If user enters "^" then out=0
;
NEW %DT,X,Y,U,PROMPT,DEFAULT,BEGDT,ENDDT
S U="^"
;
DTR1 ; -- Get beginning date
S %DT="AE"_$G(T)
I $D(AA) S PROMPT=AA
E S PROMPT="Enter the Beginning Date"_$S($G(T)]"":" @ Time",1:"")_": "
S:$D(ADEF) DEFAULT=ADEF
S BEGDT=$$DATE^BPSOSU1(PROMPT,$G(DEFAULT),1,1000101,3991231,%DT,$G(DTIME))
I BEGDT<1 QUIT 0
;
WRITE !
S %DT="AE"_$G(T)
I $D(AB) S PROMPT=AB
E S PROMPT="Enter the Ending Date"_$S($G(T)]"":" @ Time",1:"")_": "
S:$D(BDEF) DEFAULT=BDEF
S ENDDT=$$DATE^BPSOSU1(PROMPT,$G(DEFAULT),1,BEGDT,3991231,%DT,$G(DTIME))
I ENDDT["^" Q 0 ;user wants out if "^"
; -- Ensure END date is not earlier than BEG date
I ENDDT<BEGDT WRITE $C(7),!!,"Ending date must not be less than beginning date!",!! HANG 2 GOTO DTR1
QUIT BEGDT_U_ENDDT
;--------------------------------------------------------------------
;
;
DTP(AA,DEF) ;EP - *** GET A SINGLE PAST DATE, TIME NOT ALLOWED ***
;
; IN: AA = PROMPT you want displayed to user
; DEF = DEFAULT date
; OUT: FileMan Date^readable Date
; If user enters "^" then OUT=0
;
NEW %DT,Y,DATE
S:'$D(U) U="^"
I '$D(DT)#2 DO DT^DICRW ;get today's date
S U="^"
S %DT="AEPX" ;ask, echo, past dates assumed, exact date reqd
S %DT("A")=$S($D(AA):AA,1:"What DATE: ")
S:$D(DEF) %DT("B")=DEF
DO ^%DT KILL %DT
; -- Q if no data
I Y<1 QUIT 0 ;quit if date was invalid
I $D(DTOUT) QUIT 0 ;quit if timeout occurred
; -- Define dates
; DATE("Y") is FM format date; DATE is MON DD,YEAR format.
S DATE("Y")=Y XECUTE ^DD("DD") S DATE=Y
QUIT DATE("Y")_U_DATE
;--------------------------------------------------------------------
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSOSU1 6719 printed Sep 23, 2025@19:28:22 Page 2
BPSOSU1 ;BHAM ISC/FCS/DRS/FLS/DLF - copied for ECME ;03/07/08 10:34
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,7**;JUN 2004;Build 46
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;----------------------------------------------------------------------
+5 ;Standard Date Functions
+6 ;----------------------------------------------------------------------
+7 ;Standard Date PROMPT:
+8 ;
+9 ;Parameters:
+10 ; PROMPT = Text to be displayed before read
+11 ; DFLT = Default date (internal format)
+12 ; OPT = 1 - Answer optional 0 - Answer required
+13 ; SDATE = Minimum date (internal format or NOW and DT)
+14 ; EDATE = Maximum date (internal format or NOW and DT)
+15 ; %DT = E - Echo answer R - Require time
+16 ; S - Seconds returned T - Time allowed but not req
+17 ; X - Exact date req
+18 ; TIMEOUT = Number of seconds
+19 ;
+20 ;Returns:
+21 ; <null> = No response <^> - Up-arrow entered
+22 ; <-1> = Timeout occurred <^^> - Two up-arrows entered
+23 ; <date> = Internal FM Date
+24 ;----------------------------------------------------------------------
+25 ; IHS/SD/lwj 8/5/02 NCPDP 5.1 changes
+26 ; Subroutine FM3EXT cloned from FM2EXT - routine used to transfer
+27 ; the dates. Now that NCPDP 5.1 stores the field ID with all the
+28 ; fields, we needed currently just want to skip transforming the
+29 ; date for 5.1 type claims
+30 ;
+31 ;
+32 ;----------------------------------------------------------------------
DATE(PROMPT,DFLT,OPT,SDATE,EDATE,%DT,TIMEOUT) ;EP -
+1 ;
+2 NEW XDATA,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+3 ;
+4 if $GET(PROMPT)=""
QUIT ""
+5 ;
+6 SET $PIECE(DIR(0),"^",1)="DA"_$SELECT(OPT=1:"O",1:"")
+7 SET $PIECE(XDATA,":",1)=SDATE
+8 SET $PIECE(XDATA,":",2)=EDATE
+9 SET $PIECE(XDATA,":",3)=%DT
+10 SET $PIECE(DIR(0),"^",2)=XDATA
+11 SET DIR("A")=PROMPT
+12 if $GET(DFLT)'=""
SET DIR("B")=$$FM2EXT(DFLT)
+13 if +$GET(TIMEOUT)>0
SET DIR("T")=TIMEOUT
+14 DO ^DIR
+15 QUIT $SELECT($GET(DTOUT)=1:-1,$GET(DIROUT)=1:"^^",$GET(DUOUT)=1:"^",1:Y)
+16 ;----------------------------------------------------------------------
+17 ;Convert FileMan Date to External Date Format
+18 ;
+19 ;Parameters: Y - FileMan formatted date (YYYMMDD.HHMMSS)
+20 ;Returns: Y - External date
+21 ;----------------------------------------------------------------------
FM2EXT(Y) ;EP
+1 if $GET(^DD("DD"))=""
QUIT ""
+2 XECUTE ^DD("DD")
+3 QUIT $SELECT($EXTRACT(Y,1,3)?3A:Y,1:"")
+4 ;----------------------------------------------------------------------
+5 ;
FM3EXT(Y) ;EP IHS/SD/lwj 8/5/02 clone of FM2EXT- accommodates 5.1 type clms
+1 if $EXTRACT(Y,1,1)["C"
QUIT Y
+2 SET Y=Y-17000000
+3 if $GET(^DD("DD"))=""
QUIT ""
+4 XECUTE ^DD("DD")
+5 QUIT $SELECT($EXTRACT(Y,1,3)?3A:Y,1:"")
+6 ;----------------------------------------------------------------------
+7 ;
FM2MDY(Y) ;EP
+1 if Y=""
QUIT ""
+2 QUIT $EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
+3 ;----------------------------------------------------------------------
+4 ;Convert External Date to FileMan Date Format
+5 ;
+6 ;Parameters: X - External date
+7 ;Returns: Y - FileMan formatted date (YYYMMDD.HHMMSS)
+8 ;----------------------------------------------------------------------
EXT2FM(X) ;
+1 NEW %DT,Y
+2 if $GET(X)=""
QUIT ""
+3 DO ^%DT
+4 QUIT Y
+5 ;----------------------------------------------------------------------
+6 ;Returns current Date/Time in FileMan date format
NOWFM() ;EP
+1 NEW %,%H,%I,X
+2 DO NOW^%DTC
+3 QUIT %
NOWEXT() ;EP - External form of $$NOWFM
+1 NEW Y
SET Y=$$NOWFM
XECUTE ^DD("DD")
QUIT Y
+2 ;----------------------------------------------------------------------
+3 ;Takes a FileMan date and adds or subtracts days
+4 ;
+5 ;Parameters: X1 - FileMan formatted date
+6 ; X2 - Number of days (ECME = add, neg = subtract)
+7 ;Returns: X - Resulting FileMan formatted date
+8 ;----------------------------------------------------------------------
CDTFM(X1,X2) ;EP - BPSER*,BPSES02
+1 NEW X,%H
+2 if $GET(X1)=""
QUIT ""
+3 if $GET(X2)=""
QUIT ""
+4 DO C^%DTC
+5 QUIT X
+6 ;----------------------------------------------------------------------
+7 ;Takes a FileMan date and returns 3-digit julian date
JULDATE(DT) ;
+1 NEW X,X1,X2,%H,%T,%Y
+2 if '(DT?7N)
QUIT ""
+3 SET X2=$EXTRACT(DT,1,3)_"0101"
SET X1=DT
+4 DO ^%DTC
+5 SET X=X+1
+6 QUIT $TRANSLATE($JUSTIFY(X,3)," ","0")
+7 ;----------------------------------------------------------------------
+8 ;
+9 ;$$DTR(AA,AB,ADEF,BDEF,T) Input Beginning & Ending prompts, return
+10 ; "Begin date^End date" or 0 if unsuccessful.
+11 ;$$DTR() is okay - all args are optional
+12 ;$$DTP(AA,DEF) Input a prompt, return a single date "Internal^External"
+13 ;$$DTM(AA,DEF) Input a prompt, return month/year "Internal^External"
+14 ;--------------------------------------------------------------------
+15 ;
DTR(AA,AB,ADEF,BDEF,T) ;EP - GET THE DATE RANGE (beginning and ending dates)
+1 ; IN:
+2 ; AA = PROMPT for BEGINNING DATE
+3 ; AB = PROMPT for ENDING DATE
+4 ; ADEF = DEFAULT date for BEGINNING DATE
+5 ; BDEF = DEFAULT date for ENDING DATE
+6 ; T = whether TIME is allowed as entry, and if REQUIRED
+7 ; (If T="T" then TIME is allowed; is REQ'd if T="R").
+8 ; OUT:
+9 ; Beginning Date^Ending Date in 7digit FileMan format
+10 ; If user enters "^" then out=0
+11 ;
+12 NEW %DT,X,Y,U,PROMPT,DEFAULT,BEGDT,ENDDT
+13 SET U="^"
+14 ;
DTR1 ; -- Get beginning date
+1 SET %DT="AE"_$GET(T)
+2 IF $DATA(AA)
SET PROMPT=AA
+3 IF '$TEST
SET PROMPT="Enter the Beginning Date"_$SELECT($GET(T)]"":" @ Time",1:"")_": "
+4 if $DATA(ADEF)
SET DEFAULT=ADEF
+5 SET BEGDT=$$DATE^BPSOSU1(PROMPT,$GET(DEFAULT),1,1000101,3991231,%DT,$GET(DTIME))
+6 IF BEGDT<1
QUIT 0
+7 ;
+8 WRITE !
+9 SET %DT="AE"_$GET(T)
+10 IF $DATA(AB)
SET PROMPT=AB
+11 IF '$TEST
SET PROMPT="Enter the Ending Date"_$SELECT($GET(T)]"":" @ Time",1:"")_": "
+12 if $DATA(BDEF)
SET DEFAULT=BDEF
+13 SET ENDDT=$$DATE^BPSOSU1(PROMPT,$GET(DEFAULT),1,BEGDT,3991231,%DT,$GET(DTIME))
+14 ;user wants out if "^"
IF ENDDT["^"
QUIT 0
+15 ; -- Ensure END date is not earlier than BEG date
+16 IF ENDDT<BEGDT
WRITE $CHAR(7),!!,"Ending date must not be less than beginning date!",!!
HANG 2
GOTO DTR1
+17 QUIT BEGDT_U_ENDDT
+18 ;--------------------------------------------------------------------
+19 ;
+20 ;
DTP(AA,DEF) ;EP - *** GET A SINGLE PAST DATE, TIME NOT ALLOWED ***
+1 ;
+2 ; IN: AA = PROMPT you want displayed to user
+3 ; DEF = DEFAULT date
+4 ; OUT: FileMan Date^readable Date
+5 ; If user enters "^" then OUT=0
+6 ;
+7 NEW %DT,Y,DATE
+8 if '$DATA(U)
SET U="^"
+9 ;get today's date
IF '$DATA(DT)#2
DO DT^DICRW
+10 SET U="^"
+11 ;ask, echo, past dates assumed, exact date reqd
SET %DT="AEPX"
+12 SET %DT("A")=$SELECT($DATA(AA):AA,1:"What DATE: ")
+13 if $DATA(DEF)
SET %DT("B")=DEF
+14 DO ^%DT
KILL %DT
+15 ; -- Q if no data
+16 ;quit if date was invalid
IF Y<1
QUIT 0
+17 ;quit if timeout occurred
IF $DATA(DTOUT)
QUIT 0
+18 ; -- Define dates
+19 ; DATE("Y") is FM format date; DATE is MON DD,YEAR format.
+20 SET DATE("Y")=Y
XECUTE ^DD("DD")
SET DATE=Y
+21 QUIT DATE("Y")_U_DATE
+22 ;--------------------------------------------------------------------
