PXRMCDUE ;SLC/PKR - Custom date due calculation routines. ;02/04/2011
;;2.0;CLINICAL REMINDERS;**4,6,12,18**;Feb 04, 2005;Build 152
;
;========================================================
CDBUILD(STRING,DA) ;Given a custom date due string build the data
;structure. This is called by a new-style cross-reference after
;the date due string has passed the input transform so we don't need
;to validate the elements.
;Do not execute as part of a verify fields.
I $G(DIUTIL)="VERIFY FIELDS" Q
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q
N FDA,FILIST,FREQLIST,FUNCTION,IENB,IENS,IND,MSG
N OPLIST,NARGS,PFSTACK
S STRING=$$UP^XLFSTR(STRING)
D PARSE(STRING,.FUNCTION,.NARGS,.FILIST,.FREQLIST,.OPLIST)
S IENS=DA_","
S FDA(811.9,IENS,46)=FUNCTION,FDA(811.9,IENS,47)=NARGS
S IENB=DA
F IND=1:1:NARGS D
. S IENB=IENB+1
. S IENS="+"_IENB_","_DA_","
. S FDA(811.948,IENS,.01)=FILIST(IND)
. S FDA(811.948,IENS,.02)=FREQLIST(IND)
. S FDA(811.948,IENS,.03)=OPLIST(IND)
D UPDATE^DIE("","FDA","","MSG")
I $D(MSG) D
. W !,"The Custom Date Due update failed, UPDATE^DIE returned the following error message:"
. D AWRITE^PXRMUTIL("MSG")
Q
;
;========================================================
CDUEDATE(DEFARR,FIEVAL) ;Do the custom date due calculation and return
;the due date.
N DATE,DDUE,DLIST,FI,FREQ,FUNCTION,IND,PM,NARGS,TEMP
S FUNCTION=$P(DEFARR(46),U,1)
S NARGS=$P(DEFARR(46),U,2)
F IND=1:1:NARGS D
. S TEMP=DEFARR(47,IND,0)
. S FI=$P(TEMP,U,1)
. S FREQ=$P(TEMP,U,2)
. S PM=$P(TEMP,U,3)
. S DATE=$S(FIEVAL(FI):+FIEVAL(FI,"DATE"),1:0)
. I DATE>0 S DATE=$$FULLDATE^PXRMDATE(DATE)
. S DLIST(IND)=$$NEWDATE^PXRMDATE(DATE,PM,FREQ)
S TEMP=$S(FUNCTION="MAX_DATE":$$MAXDATE(NARGS,.DLIST),FUNCTION="MIN_DATE":$$MINDATE(NARGS,.DLIST),FUNCTION="RANK_DATE":$$RANKDATE(NARGS,.DLIST),1:0)
S DDUE=$P(TEMP,U,1)
I DDUE=0 Q -1
S IND=$P(TEMP,U,2)
S TEMP=DEFARR(47,IND,0)
S FI=$P(TEMP,U,1)
S FREQ=$P(TEMP,U,2)
S PM=$P(TEMP,U,3)
S DATE=+$G(FIEVAL(FI,"DATE"))
S ^TMP(PXRMPID,$J,PXRMITEM,"zCDUE")=FI_U_FREQ_U_PM_U_DATE
Q DDUE
;
;========================================================
CDKILL(X,DA) ;
;Do not execute as part of a verify fields.
I $G(DIUTIL)="VERIFY FIELDS" Q
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q
K ^PXD(811.9,DA,46),^PXD(811.9,DA,47)
Q
;
;========================================================
MAXDATE(NARGS,DLIST) ;Return the maximum date from a list of dates in DLIST.
N IND,INDS,MAXDATE
S (INDS,MAXDATE)=0
F IND=1:1:NARGS I DLIST(IND)>MAXDATE S MAXDATE=DLIST(IND),INDS=IND
Q MAXDATE_U_INDS
;
;========================================================
MINDATE(NARGS,DLIST) ;Return the minimum date from a list of dates in DLIST.
;Only return 0 if there is no "real" date in the list.
N DATE,IND,INDS,MINDATE
S INDS=0
S MINDATE=9991231
F IND=1:1:NARGS S DATE=DLIST(IND) I DATE<MINDATE,DATE'=0 S MINDATE=DATE,INDS=IND
I MINDATE=9991231 S MINDATE=0
Q MINDATE_U_INDS
;
;========================================================
OUTPUT(CDUEDATA,DEFARR) ;Build the custom date due output text.
N CDUEFI,ENTRY,FINAME,PM,TEXT,VPTR
S CDUEFI=$P(CDUEDATA,U,1)
S PM=$P(CDUEDATA,U,3)
S VPTR=$P(^PXD(811.9,DEFARR("IEN"),20,CDUEFI,0),U,1)
S ENTRY="^"_$P(VPTR,";",2)_$P(VPTR,";",1)_",0)"
S FINAME=$P(@ENTRY,U,1)
S TEXT="Custom date due based on date of finding "_CDUEFI_" ("_FINAME_")"
S TEXT=TEXT_" "_PM_" frequency of "_$P(CDUEDATA,U,2)_"."
Q TEXT
;
;========================================================
PARSE(STRING,FUNCTION,NARGS,FILIST,FREQLIST,OPLIST) ;Parse a custom date due
;string and return the function, number of arguments, finding list,
;frequency list, and operator list. An argument has the form M+NU or
;M-NU where M is a finding number, N is an integer, and U is H, D, W,
;M, or Y.
N IND,OPER,PFSTACK,PM
S OPER=","
D POSTFIX^PXRMSTAC(STRING,OPER,.PFSTACK)
S FUNCTION=$$UP^XLFSTR(PFSTACK(1))
S NARGS=0
F IND=2:1:PFSTACK(0) D
. I PFSTACK(IND)=OPER Q
. S NARGS=NARGS+1
. S PM=$S(PFSTACK(IND)["+":"+",PFSTACK(IND)["-":"-",1:"?")
. S FILIST(NARGS)=$P(PFSTACK(IND),PM,1)
. S FREQLIST(NARGS)=$P(PFSTACK(IND),PM,2)
. S OPLIST(NARGS)=PM
Q
;
;========================================================
RANKDATE(NARGS,DLIST) ;Return the first non-zero date from the list of dates
;in DLIST. Return 0 if DLIST is all zeroes.
N DATE,IND,INDS
S (DATE,INDS)=0
F IND=1:1:NARGS I DLIST(IND)>0 S DATE=DLIST(IND),INDS=IND Q
Q DATE_U_INDS
;
;========================================================
VCDUE(STRING,DA) ;Make sure a custom date due string is valid.
;Do not execute as part of a verify fields.
I $G(DIUTIL)="VERIFY FIELDS" Q 1
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q 1
I '$D(DA) Q 1
I $L(STRING)>245 Q 0
N FILIST,FREQLIST,FUNCTION,IND,OPLIST,NARGS,TEXT,VALID
D PARSE(STRING,.FUNCTION,.NARGS,.FILIST,.FREQLIST,.OPLIST)
S VALID=$$VFUN(FUNCTION)
I 'VALID D
. S TEXT=FUNCTION_" is not a valid custom date due function."
. D EN^DDIOL(TEXT)
F IND=1:1:NARGS D
. I '$D(^PXD(811.9,DA,20,FILIST(IND),0)) D
.. S TEXT="Finding number "_FILIST(IND)_" is not a valid reminder finding"
.. D EN^DDIOL(TEXT)
.. S VALID=0
. I OPLIST(IND)="?" D
.. S TEXT="'+' and '-' are the only valid operators."
.. D EN^DDIOL(TEXT)
.. S VALID=0
. I '$$VFREQ^PXRMINTR(FREQLIST(IND)) D
.. S TEXT=FREQLIST(IND)_" is not a valid frequency."
.. D EN^DDIOL(TEXT)
.. S VALID=0
Q VALID
;
;========================================================
VFUN(FUNCTION) ;Make sure FUNCTION is a valid function.
I FUNCTION="MIN_DATE" Q 1
I FUNCTION="MAX_DATE" Q 1
I FUNCTION="RANK_DATE" Q 1
Q 0
;
;========================================================
XHELP ;Executable help for custom date due.
N DONE,IND,TEXT
S DONE=0
F IND=1:1 Q:DONE D
. S TEXT=$P($T(TEXT+IND),";",3)
. I TEXT="**End Text**" S DONE=1 Q
. W !,TEXT
Q
;
;========================================================
TEXT ;Custom Date Due help text.
;;The general form for a Custom Date Due string is:
;; FUNCTION(ARG1,ARG2,...,ARGN)
;;
;;FUNCTION can be one of the following:
;; MAX_DATE - return the maximum date from the argument list
;; MIN_DATE - return the minimum date from the argument list
;; RANK_DATE - going from left to right return the first non-zero date
;; from the argument list
;;
;;The arguments have the form:
;; F+IU or F-IU where F is a finding number, I is a integer, and U
;; is one of the following units: H (hours), D (days), W (weeks),
;; M (months), or Y (years). Each argument is converted to a date
;; by adding or subtracting I*U with the date of the finding.
;;
;;Here is an example: MAX_DATE(1+6M,3-1W)
;;This will take the date of finding 1 and add 6 months, the date of finding 3
;;and subtract 1 week and set the date due to the maximum of those two dates.
;;
;;**End Text**
Q
;
PXRMCDUE ;SLC/PKR - Custom date due calculation routines. ;02/04/2011
+1 ;;2.0;CLINICAL REMINDERS;**4,6,12,18**;Feb 04, 2005;Build 152
+2 ;
+3 ;========================================================
CDBUILD(STRING,DA) ;Given a custom date due string build the data
+1 ;structure. This is called by a new-style cross-reference after
+2 ;the date due string has passed the input transform so we don't need
+3 ;to validate the elements.
+4 ;Do not execute as part of a verify fields.
+5 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT
+6 ;Do not execute as part of exchange.
+7 IF $GET(PXRMEXCH)
QUIT
+8 NEW FDA,FILIST,FREQLIST,FUNCTION,IENB,IENS,IND,MSG
+9 NEW OPLIST,NARGS,PFSTACK
+10 SET STRING=$$UP^XLFSTR(STRING)
+11 DO PARSE(STRING,.FUNCTION,.NARGS,.FILIST,.FREQLIST,.OPLIST)
+12 SET IENS=DA_","
+13 SET FDA(811.9,IENS,46)=FUNCTION
SET FDA(811.9,IENS,47)=NARGS
+14 SET IENB=DA
+15 FOR IND=1:1:NARGS
Begin DoDot:1
+16 SET IENB=IENB+1
+17 SET IENS="+"_IENB_","_DA_","
+18 SET FDA(811.948,IENS,.01)=FILIST(IND)
+19 SET FDA(811.948,IENS,.02)=FREQLIST(IND)
+20 SET FDA(811.948,IENS,.03)=OPLIST(IND)
End DoDot:1
+21 DO UPDATE^DIE("","FDA","","MSG")
+22 IF $DATA(MSG)
Begin DoDot:1
+23 WRITE !,"The Custom Date Due update failed, UPDATE^DIE returned the following error message:"
+24 DO AWRITE^PXRMUTIL("MSG")
End DoDot:1
+25 QUIT
+26 ;
+27 ;========================================================
CDUEDATE(DEFARR,FIEVAL) ;Do the custom date due calculation and return
+1 ;the due date.
+2 NEW DATE,DDUE,DLIST,FI,FREQ,FUNCTION,IND,PM,NARGS,TEMP
+3 SET FUNCTION=$PIECE(DEFARR(46),U,1)
+4 SET NARGS=$PIECE(DEFARR(46),U,2)
+5 FOR IND=1:1:NARGS
Begin DoDot:1
+6 SET TEMP=DEFARR(47,IND,0)
+7 SET FI=$PIECE(TEMP,U,1)
+8 SET FREQ=$PIECE(TEMP,U,2)
+9 SET PM=$PIECE(TEMP,U,3)
+10 SET DATE=$SELECT(FIEVAL(FI):+FIEVAL(FI,"DATE"),1:0)
+11 IF DATE>0
SET DATE=$$FULLDATE^PXRMDATE(DATE)
+12 SET DLIST(IND)=$$NEWDATE^PXRMDATE(DATE,PM,FREQ)
End DoDot:1
+13 SET TEMP=$SELECT(FUNCTION="MAX_DATE":$$MAXDATE(NARGS,.DLIST),FUNCTION="MIN_DATE":$$MINDATE(NARGS,.DLIST),FUNCTION="RANK_DATE":$$RANKDATE(NARGS,.DLIST),1:0)
+14 SET DDUE=$PIECE(TEMP,U,1)
+15 IF DDUE=0
QUIT -1
+16 SET IND=$PIECE(TEMP,U,2)
+17 SET TEMP=DEFARR(47,IND,0)
+18 SET FI=$PIECE(TEMP,U,1)
+19 SET FREQ=$PIECE(TEMP,U,2)
+20 SET PM=$PIECE(TEMP,U,3)
+21 SET DATE=+$GET(FIEVAL(FI,"DATE"))
+22 SET ^TMP(PXRMPID,$JOB,PXRMITEM,"zCDUE")=FI_U_FREQ_U_PM_U_DATE
+23 QUIT DDUE
+24 ;
+25 ;========================================================
CDKILL(X,DA) ;
+1 ;Do not execute as part of a verify fields.
+2 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT
+3 ;Do not execute as part of exchange.
+4 IF $GET(PXRMEXCH)
QUIT
+5 KILL ^PXD(811.9,DA,46),^PXD(811.9,DA,47)
+6 QUIT
+7 ;
+8 ;========================================================
MAXDATE(NARGS,DLIST) ;Return the maximum date from a list of dates in DLIST.
+1 NEW IND,INDS,MAXDATE
+2 SET (INDS,MAXDATE)=0
+3 FOR IND=1:1:NARGS
IF DLIST(IND)>MAXDATE
SET MAXDATE=DLIST(IND)
SET INDS=IND
+4 QUIT MAXDATE_U_INDS
+5 ;
+6 ;========================================================
MINDATE(NARGS,DLIST) ;Return the minimum date from a list of dates in DLIST.
+1 ;Only return 0 if there is no "real" date in the list.
+2 NEW DATE,IND,INDS,MINDATE
+3 SET INDS=0
+4 SET MINDATE=9991231
+5 FOR IND=1:1:NARGS
SET DATE=DLIST(IND)
IF DATE<MINDATE
IF DATE'=0
SET MINDATE=DATE
SET INDS=IND
+6 IF MINDATE=9991231
SET MINDATE=0
+7 QUIT MINDATE_U_INDS
+8 ;
+9 ;========================================================
OUTPUT(CDUEDATA,DEFARR) ;Build the custom date due output text.
+1 NEW CDUEFI,ENTRY,FINAME,PM,TEXT,VPTR
+2 SET CDUEFI=$PIECE(CDUEDATA,U,1)
+3 SET PM=$PIECE(CDUEDATA,U,3)
+4 SET VPTR=$PIECE(^PXD(811.9,DEFARR("IEN"),20,CDUEFI,0),U,1)
+5 SET ENTRY="^"_$PIECE(VPTR,";",2)_$PIECE(VPTR,";",1)_",0)"
+6 SET FINAME=$PIECE(@ENTRY,U,1)
+7 SET TEXT="Custom date due based on date of finding "_CDUEFI_" ("_FINAME_")"
+8 SET TEXT=TEXT_" "_PM_" frequency of "_$PIECE(CDUEDATA,U,2)_"."
+9 QUIT TEXT
+10 ;
+11 ;========================================================
PARSE(STRING,FUNCTION,NARGS,FILIST,FREQLIST,OPLIST) ;Parse a custom date due
+1 ;string and return the function, number of arguments, finding list,
+2 ;frequency list, and operator list. An argument has the form M+NU or
+3 ;M-NU where M is a finding number, N is an integer, and U is H, D, W,
+4 ;M, or Y.
+5 NEW IND,OPER,PFSTACK,PM
+6 SET OPER=","
+7 DO POSTFIX^PXRMSTAC(STRING,OPER,.PFSTACK)
+8 SET FUNCTION=$$UP^XLFSTR(PFSTACK(1))
+9 SET NARGS=0
+10 FOR IND=2:1:PFSTACK(0)
Begin DoDot:1
+11 IF PFSTACK(IND)=OPER
QUIT
+12 SET NARGS=NARGS+1
+13 SET PM=$SELECT(PFSTACK(IND)["+":"+",PFSTACK(IND)["-":"-",1:"?")
+14 SET FILIST(NARGS)=$PIECE(PFSTACK(IND),PM,1)
+15 SET FREQLIST(NARGS)=$PIECE(PFSTACK(IND),PM,2)
+16 SET OPLIST(NARGS)=PM
End DoDot:1
+17 QUIT
+18 ;
+19 ;========================================================
RANKDATE(NARGS,DLIST) ;Return the first non-zero date from the list of dates
+1 ;in DLIST. Return 0 if DLIST is all zeroes.
+2 NEW DATE,IND,INDS
+3 SET (DATE,INDS)=0
+4 FOR IND=1:1:NARGS
IF DLIST(IND)>0
SET DATE=DLIST(IND)
SET INDS=IND
QUIT
+5 QUIT DATE_U_INDS
+6 ;
+7 ;========================================================
VCDUE(STRING,DA) ;Make sure a custom date due string is valid.
+1 ;Do not execute as part of a verify fields.
+2 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT 1
+3 ;Do not execute as part of exchange.
+4 IF $GET(PXRMEXCH)
QUIT 1
+5 IF '$DATA(DA)
QUIT 1
+6 IF $LENGTH(STRING)>245
QUIT 0
+7 NEW FILIST,FREQLIST,FUNCTION,IND,OPLIST,NARGS,TEXT,VALID
+8 DO PARSE(STRING,.FUNCTION,.NARGS,.FILIST,.FREQLIST,.OPLIST)
+9 SET VALID=$$VFUN(FUNCTION)
+10 IF 'VALID
Begin DoDot:1
+11 SET TEXT=FUNCTION_" is not a valid custom date due function."
+12 DO EN^DDIOL(TEXT)
End DoDot:1
+13 FOR IND=1:1:NARGS
Begin DoDot:1
+14 IF '$DATA(^PXD(811.9,DA,20,FILIST(IND),0))
Begin DoDot:2
+15 SET TEXT="Finding number "_FILIST(IND)_" is not a valid reminder finding"
+16 DO EN^DDIOL(TEXT)
+17 SET VALID=0
End DoDot:2
+18 IF OPLIST(IND)="?"
Begin DoDot:2
+19 SET TEXT="'+' and '-' are the only valid operators."
+20 DO EN^DDIOL(TEXT)
+21 SET VALID=0
End DoDot:2
+22 IF '$$VFREQ^PXRMINTR(FREQLIST(IND))
Begin DoDot:2
+23 SET TEXT=FREQLIST(IND)_" is not a valid frequency."
+24 DO EN^DDIOL(TEXT)
+25 SET VALID=0
End DoDot:2
End DoDot:1
+26 QUIT VALID
+27 ;
+28 ;========================================================
VFUN(FUNCTION) ;Make sure FUNCTION is a valid function.
+1 IF FUNCTION="MIN_DATE"
QUIT 1
+2 IF FUNCTION="MAX_DATE"
QUIT 1
+3 IF FUNCTION="RANK_DATE"
QUIT 1
+4 QUIT 0
+5 ;
+6 ;========================================================
XHELP ;Executable help for custom date due.
+1 NEW DONE,IND,TEXT
+2 SET DONE=0
+3 FOR IND=1:1
IF DONE
QUIT
Begin DoDot:1
+4 SET TEXT=$PIECE($TEXT(TEXT+IND),";",3)
+5 IF TEXT="**End Text**"
SET DONE=1
QUIT
+6 WRITE !,TEXT
End DoDot:1
+7 QUIT
+8 ;
+9 ;========================================================
TEXT ;Custom Date Due help text.
+1 ;;The general form for a Custom Date Due string is:
+2 ;; FUNCTION(ARG1,ARG2,...,ARGN)
+3 ;;
+4 ;;FUNCTION can be one of the following:
+5 ;; MAX_DATE - return the maximum date from the argument list
+6 ;; MIN_DATE - return the minimum date from the argument list
+7 ;; RANK_DATE - going from left to right return the first non-zero date
+8 ;; from the argument list
+9 ;;
+10 ;;The arguments have the form:
+11 ;; F+IU or F-IU where F is a finding number, I is a integer, and U
+12 ;; is one of the following units: H (hours), D (days), W (weeks),
+13 ;; M (months), or Y (years). Each argument is converted to a date
+14 ;; by adding or subtracting I*U with the date of the finding.
+15 ;;
+16 ;;Here is an example: MAX_DATE(1+6M,3-1W)
+17 ;;This will take the date of finding 1 and add 6 months, the date of finding 3
+18 ;;and subtract 1 week and set the date due to the maximum of those two dates.
+19 ;;
+20 ;;**End Text**
+21 QUIT
+22 ;
