Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSSHFREQ

PSSHFREQ.m

Go to the documentation of this file.
  1. PSSHFREQ ;WOIFO/AV - VALIDATES FREQUENCY FOR DOSING ;09/20/07
  1. ;;1.0;PHARMACY DATA MANAGEMENT;**136**;9/30/97;Build 89
  1. ;
  1. ;
  1. QUIT
  1. ;;
  1. VALFREQ(FREQ) ;
  1. ;
  1. NEW PSS,RSLT
  1. ;
  1. SET FREQ=$$TRIM(FREQ)
  1. ;
  1. ; Invalid frequency exit routine
  1. IF FREQ="" QUIT 0
  1. ;
  1. SET FREQ=$$UPPER(FREQ)
  1. ;
  1. ; Determine if frequency has decimals, if so invalid
  1. IF FREQ["." QUIT 0
  1. ; Determine if frequency is a number, if so it is valid
  1. IF FREQ?1.N QUIT 1
  1. ;
  1. ; Determine if frequency is one of the special frequency strings
  1. SET RSLT=$$SMPLFREQ(FREQ)
  1. IF RSLT=1 QUIT RSLT
  1. ;
  1. SET PSS("length")=$LENGTH(FREQ)
  1. SET PSS("firstCharacter")=$EXTRACT(FREQ,1,1)
  1. SET PSS("lastCharacter")=$EXTRACT(FREQ,PSS("length"),PSS("length"))
  1. ;
  1. ; Frequency must meet the following criteria else quit
  1. ; Length must be less than or equal to 4 or more than or equal to 3
  1. IF PSS("length")>4 QUIT 0
  1. IF PSS("length")<3 QUIT 0
  1. ; First character must be a Q or X
  1. ;IF (PSS("firstCharacter")'="Q")&&(PSS("firstCharacter")'="X") QUIT 0
  1. I "XQ"'[PSS("firstCharacter") Q 0
  1. ;
  1. SET PSS("result")=1
  1. IF PSS("length")=4 DO
  1. . ; Take two middle characters and ensure they are numbers
  1. . SET PSS("chrTemp1")=$EXTRACT(FREQ,2,2)
  1. . SET PSS("chrTemp2")=$EXTRACT(FREQ,3,3)
  1. . ; ASCII number characters are 48 - 57
  1. . SET PSS("intTemp1")=$ASCII(PSS("chrTemp1"))-48
  1. . SET PSS("intTemp2")=$ASCII(PSS("chrTemp2"))-48
  1. . ;
  1. . ; Ensure the two middle chars are numbers
  1. . IF PSS("intTemp1")<0 SET PSS("result")=0
  1. . IF PSS("intTemp1")>9 SET PSS("result")=0
  1. . IF PSS("intTemp2")<0 SET PSS("result")=0
  1. . IF PSS("intTemp2")>9 SET PSS("result")=0
  1. . QUIT
  1. ;
  1. IF PSS("length")=3 DO
  1. . ; Take two middle characters
  1. . SET PSS("chrTemp1")=$EXTRACT(FREQ,2,2)
  1. . ; ASCII number characters are 48 - 57
  1. . SET PSS("intTemp1")=$ASCII(PSS("chrTemp1"))-48
  1. . ;
  1. . ; Ensure the middle char is a number
  1. . IF PSS("intTemp1")<0 SET PSS("result")=0
  1. . IF PSS("intTemp1")>9 SET PSS("result")=0
  1. . QUIT
  1. ;
  1. IF PSS("result")=0 QUIT 0
  1. ;
  1. ; validate the first and last character
  1. ; If Q is first character
  1. SET PSS("qResult")=""
  1. IF PSS("firstCharacter")="Q" DO
  1. . IF PSS("lastCharacter")="D" SET PSS("qResult")=1 QUIT
  1. . IF PSS("lastCharacter")="W" SET PSS("qResult")=1 QUIT
  1. . IF PSS("lastCharacter")="L" SET PSS("qResult")=1 QUIT
  1. . IF PSS("lastCharacter")="H" SET PSS("qResult")=1 QUIT
  1. . IF PSS("qResult")="" SET PSS("qResult")=0
  1. . QUIT
  1. ;
  1. IF PSS("qResult")'="" QUIT PSS("qResult")
  1. ;
  1. ; If X is first character
  1. SET PSS("xResult")=""
  1. IF PSS("firstCharacter")="X" DO
  1. . IF PSS("lastCharacter")="D" SET PSS("xResult")=1 QUIT
  1. . IF PSS("lastCharacter")="W" SET PSS("xResult")=1 QUIT
  1. . IF PSS("lastCharacter")="L" SET PSS("xResult")=1 QUIT
  1. . IF PSS("xResult")="" SET PSS("xResult")=0
  1. . QUIT
  1. IF PSS("xResult")'="" QUIT PSS("xResult")
  1. ;
  1. QUIT 0
  1. ;;
  1. SMPLFREQ(FREQ) ;
  1. ; @DESC Determines if the frequency is one of the special
  1. ; frequency strings that is accepted
  1. ;
  1. ; @FREQ Frequency passed in
  1. ;
  1. ; @RETURNS 1 if is valid frequency or 0 if not one of special
  1. ; frequencies
  1. ;
  1. NEW VAL,RSLT,FREQS
  1. ;
  1. ; Hash of valid frequencies
  1. SET FREQS("QD")=""
  1. SET FREQS("BID")=""
  1. SET FREQS("TID")=""
  1. SET FREQS("QID")=""
  1. SET FREQS("QAM")=""
  1. SET FREQS("QSHIFT")=""
  1. SET FREQS("QOD")=""
  1. SET FREQS("QHS")=""
  1. SET FREQS("QPM")=""
  1. ;
  1. SET VAL=""
  1. SET RSLT=0
  1. FOR SET VAL=$ORDER(FREQS(VAL)) QUIT:VAL="" DO
  1. . ; Iterate through valid frequencies and determine
  1. . ; if frequency parameter is a match return 1
  1. . IF FREQ=VAL SET RSLT=1 QUIT
  1. . QUIT
  1. ;
  1. QUIT RSLT
  1. ;;
  1. TRIM(TEXT) ;
  1. ;Trims the leading and trailing whitespace from a String
  1. ;
  1. ;Trim leading whitespace
  1. SET TEXT=$$TRIMLEAD(TEXT)
  1. ;Trim trailing whitespace
  1. SET TEXT=$$TRIMEND(TEXT)
  1. QUIT TEXT
  1. ;;
  1. TRIMLEAD(TEXT) ;
  1. ;Trims the leading whitespace from a String
  1. ;
  1. NEW LENGTH,N,FLAG,CHAR,TEMPTEXT,MOD
  1. ;
  1. ;Ensure the String contains a value
  1. IF $DATA(TEXT)=0 SET TEXT="" QUIT TEXT
  1. SET LENGTH=$LENGTH(TEXT)
  1. ;Ensure the String is not empty
  1. IF LENGTH=0 QUIT TEXT
  1. ;
  1. ;Initialize the flag
  1. S FLAG=0,N=0,MOD=0
  1. ;Loop through
  1. FOR SET N=N+1 QUIT:N>LENGTH!(FLAG=1) DO
  1. .SET CHAR=$EXTRACT(TEXT,N)
  1. .IF CHAR=" " SET TEMPTEXT=$EXTRACT(TEXT,N+1,LENGTH),MOD=1
  1. .IF CHAR'=" " SET FLAG=1
  1. .QUIT ;End for loop
  1. ;Save the new text to the passed in variable
  1. IF MOD=1 SET TEXT=TEMPTEXT
  1. QUIT TEXT
  1. ;;
  1. TRIMEND(TEXT) ;
  1. ;Trims the trailing whitespace from a String
  1. ;
  1. NEW LENGTH,N,FLAG,CHAR,TEMPTEXT,MOD
  1. ;
  1. ;Ensure the String contains a value
  1. IF $DATA(TEXT)=0 SET TEXT="" QUIT TEXT
  1. SET LENGTH=$LENGTH(TEXT)
  1. ;Ensure the String is not empty
  1. IF LENGTH=0 QUIT TEXT
  1. ;
  1. ;Initialize the flag, counter, and modification indicator variables
  1. S FLAG=0,N=LENGTH+1,MOD=0
  1. ;Loop through
  1. FOR SET N=N-1 QUIT:N=0!(FLAG=1) DO
  1. .SET CHAR=$EXTRACT(TEXT,N)
  1. .;WRITE !,"CHAR: ",CHAR
  1. .IF CHAR=" " SET TEMPTEXT=$EXTRACT(TEXT,1,N-1),MOD=1
  1. .IF CHAR'=" " SET FLAG=1
  1. .QUIT ;End for loop
  1. ;Save the new text to the passed in variable
  1. IF MOD=1 SET TEXT=TEMPTEXT
  1. QUIT TEXT
  1. ;;
  1. UPPER(TEXT) ;
  1. ; @DESC Converts lowercase characters to uppercase
  1. ;
  1. ; @TEXT Text to be converted
  1. ;
  1. ; @RETURNS Text in all UPPPERCASE
  1. ;
  1. NEW LOWER,UPPER
  1. ;
  1. SET LOWER="abcdefghijklmnopqrstuvwxyz"
  1. SET UPPER="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  1. SET TEXT=$TRANSLATE(TEXT,LOWER,UPPER)
  1. ;
  1. QUIT TEXT
  1. ;;