- 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
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMCDUE 7047 printed Feb 18, 2025@23:09:31 Page 2
- 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 ;