XTVSLPR2 ;ALBANY FO/GTS - VistA Package Sizing Manager; 23-JAN-2022
;;7.3;TOOLKIT;**152**;Apr 25, 1995;Build 3
;Per VA Directive 6402, this routine should not be modified.
;
;APIs
SELLIST(SELARY,ITEMNUM,X,PARAMSTR) ; List the items for selection
; INPUT: SELARY - Array of items [passed by parameter]
; ITEMNUM - Number of items in SELARY [passed by parameter]
; X - Value entered by user [passed by parameter, will be translated to uppercase,
; value returned will be: "" - TimeOut; KILLed X - nothing selected; number - SELARY node #]
; PARAMSTR - Array of string parameters as follows:
; PARAMSTR("ADDITM") - 1 : Allow adding new item
; 2nd ^ pce = 1: Allow duplicates
; [E.G. 1 - Do not allow duplicates
; 1^1 - Allow duplicates]
; 0 : Do not allow adding new item [Default]
; PARMSTR("XTUPCASE") - 0 : Allow lowercase text [default] [Case matters]
; 1 : Convert all text to uppercase
; PARAMSTR("PATRN")) - String the defines the pattern the item text
; must match in a pattern match compare.
; [I.E. ?.ANP]
; 1 : Change user entry to uppercase
; PARAMSTR("MINLNG") - Minumum length of entered string [Default 4]
; PARAMSTR("MAXLNG") - Maximum length of entered string [Default 50]
;
NEW CURITMNM,ITMNMEU,ITMNMEL,XUPPER,ITEMLIST,ITMCNT,XACTMAT,ADDANS,OKANS
NEW MINLNG,MAXLNG,PATRN,ADDITM,XTUPCASE
;
IF $G(PARAMSTR("PATRN"))="" SET PARAMSTR("PATRN")=".ANP" ;Default pattern
IF +$G(PARAMSTR("MINLNG"))'>0 SET PARAMSTR("MINLNG")=4 ;Set default Min Length
IF +$G(PARAMSTR("MAXLNG"))'>0 SET PARAMSTR("MAXLNG")=50 ;Set default Max Length
SET MINLNG=PARAMSTR("MINLNG")
SET MAXLNG=PARAMSTR("MAXLNG")
SET PATRN=PARAMSTR("PATRN")
SET ADDITM=$G(PARAMSTR("ADDITM"))
IF +ADDITM=0 SET ADDITM=0 ;Set default ADDITM
SET XTUPCASE=+$G(PARAMSTR("XTUPCASE"))
;
DO CLNXEND(.X) ;Cleanup control chars, leading and trailing spaces in X
;
IF +$G(XTUPCASE) SET X=$$UP^XLFSTR(X) SET PATRN=$$UP^XLFSTR(PATRN) ;Only upper case for user entry
SET XUPPER=$$UP^XLFSTR(X)
;
;Count items in SELARY and find matches
SET (XACTMAT,CURITMNM,ITMCNT)=0
FOR SET CURITMNM=$O(SELARY(CURITMNM)) Q:CURITMNM="" DO
. SET ITMNMEU=$$UP^XLFSTR($P(SELARY(CURITMNM),"^",1))
. SET ITMNMEL=$P(SELARY(CURITMNM),"^",1)
. IF ('XACTMAT) DO
.. IF +$G(XTUPCASE),(ITMNMEU)=XUPPER SET XACTMAT=CURITMNM ; Case doesn't matter
.. IF '+$G(XTUPCASE),(ITMNMEL)=X SET XACTMAT=CURITMNM ; Case matters
. IF +$G(XTUPCASE),$E(ITMNMEU,1,$L(XUPPER))=XUPPER SET ITMCNT=ITMCNT+1 SET ITEMLIST(ITMCNT)=ITMNMEL_"^"_CURITMNM ; ITEMLIST = match array [case doesn't matter
. IF '+$G(XTUPCASE),$E(ITMNMEL,1,$L(X))=X SET ITMCNT=ITMCNT+1 SET ITEMLIST(ITMCNT)=ITMNMEL_"^"_CURITMNM ; ITEMLIST = match array [case matters]
;
IF ITMCNT>1 DO ; Present list to user for selection when ITMCNT>1
. NEW XVAL,XTOUT
. SET XVAL=-1 ;Initialize selected Item #
. SET (XTOUT,CURITMNM)=0
. FOR SET CURITMNM=$O(ITEMLIST(CURITMNM)) QUIT:+CURITMNM=0 Q:XTOUT Q:($E(XVAL,1)="^") QUIT:(XVAL?1.N) DO ;List items
.. WRITE !," ",CURITMNM,": ",$P(ITEMLIST(CURITMNM),"^")
.. IF '(CURITMNM#5)!(CURITMNM=ITMCNT) DO
... FOR W:(CURITMNM'=ITMCNT) !,"Press <Enter> to see more items, '^' to exit, OR" W !,"Choose 1-"_CURITMNM_": " READ XVAL:DTIME SET:'$T XTOUT=1 Q:XTOUT Q:$E(XVAL,1)="^" Q:XVAL="" Q:((XVAL?1.N)&((+XVAL>0)&(+XVAL<(CURITMNM+1)))) DO
.... IF 'XTOUT,((XVAL'?1.N)!(+XVAL>(CURITMNM))!(+XVAL<1)) W:($E(XVAL,1)'="?") " ??" W !,"Select an item from the list [Number 1 - "_CURITMNM_"]",!
. ;
. IF $E(XVAL,1)="^" KILL X ; ^ out
. IF XTOUT SET X="" ; Timeout
. ;
. IF 'ADDITM,'XTOUT,($E(XVAL,1)'="^") DO
.. IF (+XVAL=0) DO
... IF 'XACTMAT KILL X ; No item selected, Kill X for return to ^DIR
... IF XACTMAT DO
.... SET OKANS=$$YNCHK^XTVSLAPI(" "_X_" ...OK","YES")
.... IF OKANS SET X=XACTMAT ; X = Exact match entry #
.... IF 'OKANS,('$P(OKANS,"^",3)) KILL X
.... IF 'OKANS,($P(OKANS,"^",3)) SET X="" ;Timeout
. ;
. IF ADDITM,'XTOUT,($E(XVAL,1)'="^") DO
.. IF $P(ADDITM,"^",2),XACTMAT,(+XVAL=0) DO
... DO ASKADD(.ADDANS,.X,.SELARY,.ITEMNUM) ;ASKADD KILLs X on ^ or NO add
... IF 'ADDANS,($P(ADDANS,"^",3)) SET X="" ;Timeout
..;
.. IF ('$P(ADDITM,"^",2)),XACTMAT,(+XVAL=0) KILL X
.. ;
.. IF 'XACTMAT,(+XVAL=0) DO
... IF '$$BADENT(MINLNG,MAXLNG,PATRN,.X) DO
.... DO ASKADD(.ADDANS,.X,.SELARY,.ITEMNUM)
.... IF 'ADDANS,($P(ADDANS,"^",3)) SET X="" ;Timeout
. ;
. IF ('XTOUT),(+XVAL>0) SET X=$P(ITEMLIST(XVAL),"^",2) ; X = SELARY selection #
;
IF ITMCNT=1 DO
. NEW ONEITMEN,ONEITMNM
. SET ONEITMEN=$P(ITEMLIST(1),"^",2)
. SET ONEITMNM=$P(ITEMLIST(1),"^",1)
. WRITE $E(ONEITMNM,$L(X)+1,$L(ONEITMNM))
. IF ADDITM DO
.. SET OKANS=$$YNCHK^XTVSLAPI(" ...OK","YES")
.. IF OKANS SET X=ONEITMEN
.. ;
.. IF 'OKANS,($P(OKANS,"^",2)=-1),('$P(OKANS,"^",3)) KILL X ; ^ out
.. IF 'OKANS,('$P(OKANS,"^",2)),('$P(OKANS,"^",3)),('$$BADENT(MINLNG,MAXLNG,PATRN,.X)) DO
... IF ($P(ADDITM,"^",2)) DO ASKADD(.ADDANS,.X,.SELARY,.ITEMNUM) ;Dup's allowed
... IF ('$P(ADDITM,"^",2)),($G(X)'=ONEITMNM) DO ASKADD(.ADDANS,.X,.SELARY,.ITEMNUM)
... IF ('$P(ADDITM,"^",2)),($G(X)=ONEITMNM) KILL X ; No dup's
.. ;
.. IF ($P($G(OKANS),"^",3))!($P($G(ADDANS),"^",3)) SET X="" ; Timeout
. ;
. IF 'ADDITM DO
.. SET OKANS=$$YNCHK^XTVSLAPI(" ...OK","YES")
.. IF OKANS SET X=ONEITMEN
.. IF 'OKANS,('$P(OKANS,"^",3)) KILL X
.. IF 'OKANS,($P(OKANS,"^",3)) SET X="" ;Timeout
;
IF ITMCNT=0 DO
. IF ADDITM,'$$BADENT(MINLNG,MAXLNG,PATRN,.X) DO
.. DO ASKADD(.ADDANS,.X,.SELARY,.ITEMNUM)
.. IF 'ADDANS,($P(ADDANS,"^",3)) SET X="" ; Time out
. IF 'ADDITM KILL X
;
QUIT
;
ASKADD(ADDANS,X,SELARY,ITEMNUM) ; Query to Add item
SET ADDANS=$$YNCHK^XTVSLAPI(" Are you adding "_X)
IF ADDANS DO INSRTX^XTVSLAPI(.X,.SELARY,.ITEMNUM)
IF 'ADDANS,('$P(ADDANS,"^",3)) KILL X ; ^ or Not Adding
QUIT
;
CLNXEND(XVAL) ; Removes control chars from end & spaces from beginning and end
; INPUT: XVAL - String to clean up [Passed by reference]
; (Removes control characters and trailing spaces from a string)
;
NEW LPCNT,CLNX,CHKCHAR
SET CLNX=X
FOR LPCNT=1:1:$L(X) S CHKCHAR=$ASCII($E(X,LPCNT)) SET:((CHKCHAR<33)!(CHKCHAR>126)) X=$TRANSLATE(X,($E(X,LPCNT))," ")
FOR LPCNT=$L(X):-1:1 S CHKCHAR=$ASCII($E(X,LPCNT)) QUIT:((CHKCHAR>32)&(CHKCHAR<127)) S CLNX=$E(X,1,LPCNT-1)
;
S LPCNT=0
FOR S LPCNT=LPCNT+1 S CHKCHAR=$ASCII($E(CLNX,LPCNT)) QUIT:(CHKCHAR'=32) S CLNX=$E(CLNX,LPCNT+1,$L(CLNX))
;
SET X=CLNX
QUIT
;
PTRNDESC(PATRN) ; Pattern Description
; Returns a description string for type of string
NEW PATDESC,PTRNPARS,PTRNTXT,BEGTXT,ENDTXT
SET (PTRNTXT,PATDESC)=""
SET PATRNPARS=$$PTRNEXT(PATRN) ;Change pattern codes to uppercase, not strings in pattern
SET BEGTXT=$P(PATRNPARS,"^",3)
SET ENDTXT=$P(PATRNPARS,"^",4)
SET PATRN=$P(PATRNPARS,"^",2)
IF PATRN["A" SET PATDESC=PATDESC_" Alpha"
IF PATRN["N" SET PATDESC=PATDESC_$S(PATDESC'["Alpha":" Numeric",1:"-Numeric")
IF PATRN["P" SET PATDESC=PATDESC_$S((PATDESC'["Alpha")&(PATDESC'["Numeric"):" Punctuation",1:"-Punctuation")
IF BEGTXT]"" SET PTRNTXT=$S(ENDTXT="":" and",1:",")_" begin with '"_BEGTXT_"'"
IF ENDTXT]"" SET PTRNTXT=PTRNTXT_" and end with '"_ENDTXT_"'"
SET PATDESC=PATDESC_PTRNTXT_"."
QUIT PATDESC
;
PTRNEXT(PATRN) ; Extract PATTERN characters, Change lower case pattern codes to uppercase
;Return a 4 ^ pce result where:
; Pce 1 - PATRN with lower case patern codes changed to uppercase
; Pce 2 - Uppercase Pattern Codes
; Pce 3 - A string that the item must begin with
; Pce 4 - A string that the item must end with
;
NEW PTRNCHRS,QUOTOPEN,POSCTR,CHKCHAR,SETPCHAR,PTRNCODE,PTRNBEG,PTRNEND
SET (PTRNCODE,PTRNCHRS,PTRNBEG,PTRNEND)=""
SET (SETPCHAR,QUOTOPEN)=0
FOR POSCTR=1:1:$L(PATRN) DO
. SET CHKCHAR=$E(PATRN,POSCTR)
. IF CHKCHAR="""",('QUOTOPEN) SET (SETPCHAR,QUOTOPEN)=1 SET PTRNCHRS=PTRNCHRS_CHKCHAR
. ;
. IF CHKCHAR="""",(QUOTOPEN),('SETPCHAR) DO
.. SET QUOTOPEN=0
.. SET SETPCHAR=1
.. SET PTRNCHRS=PTRNCHRS_CHKCHAR
. ;
. IF CHKCHAR'="""",(QUOTOPEN),('SETPCHAR) DO
.. SET PTRNCHRS=PTRNCHRS_CHKCHAR
.. SET:PTRNCODE="" PTRNBEG=PTRNBEG_CHKCHAR
.. SET:PTRNCODE'="" PTRNEND=PTRNEND_CHKCHAR
. ;
. IF CHKCHAR'="""",('QUOTOPEN),('SETPCHAR) DO
.. SET PTRNCHRS=PTRNCHRS_$$UP^XLFSTR(CHKCHAR)
.. IF "ANP"[$$UP^XLFSTR(CHKCHAR) SET PTRNCODE=PTRNCODE_$$UP^XLFSTR(CHKCHAR)
. SET SETPCHAR=0
QUIT PTRNCHRS_"^"_PTRNCODE_"^"_PTRNBEG_"^"_PTRNEND
;
BADENT(MINLNG,MAXLNG,PATRN,X) ;Evaluate X for String PATTERN and Length req's
; RESULT : 0 - entry meets requirements
; 1 - entry doesn't meet requirements
;
NEW RESULT
SET RESULT=0
IF (($L(X)<MINLNG)!($L(X)>MAXLNG)!(X'?@PATRN)) DO
. KILL X
. WRITE !," Item must be "_MINLNG_" to "_MAXLNG_" characters made up of...",!," ",$$PTRNDESC(PATRN)
. SET RESULT=1
QUIT RESULT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTVSLPR2 9521 printed Dec 13, 2024@02:42:18 Page 2
XTVSLPR2 ;ALBANY FO/GTS - VistA Package Sizing Manager; 23-JAN-2022
+1 ;;7.3;TOOLKIT;**152**;Apr 25, 1995;Build 3
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;APIs
SELLIST(SELARY,ITEMNUM,X,PARAMSTR) ; List the items for selection
+1 ; INPUT: SELARY - Array of items [passed by parameter]
+2 ; ITEMNUM - Number of items in SELARY [passed by parameter]
+3 ; X - Value entered by user [passed by parameter, will be translated to uppercase,
+4 ; value returned will be: "" - TimeOut; KILLed X - nothing selected; number - SELARY node #]
+5 ; PARAMSTR - Array of string parameters as follows:
+6 ; PARAMSTR("ADDITM") - 1 : Allow adding new item
+7 ; 2nd ^ pce = 1: Allow duplicates
+8 ; [E.G. 1 - Do not allow duplicates
+9 ; 1^1 - Allow duplicates]
+10 ; 0 : Do not allow adding new item [Default]
+11 ; PARMSTR("XTUPCASE") - 0 : Allow lowercase text [default] [Case matters]
+12 ; 1 : Convert all text to uppercase
+13 ; PARAMSTR("PATRN")) - String the defines the pattern the item text
+14 ; must match in a pattern match compare.
+15 ; [I.E. ?.ANP]
+16 ; 1 : Change user entry to uppercase
+17 ; PARAMSTR("MINLNG") - Minumum length of entered string [Default 4]
+18 ; PARAMSTR("MAXLNG") - Maximum length of entered string [Default 50]
+19 ;
+20 NEW CURITMNM,ITMNMEU,ITMNMEL,XUPPER,ITEMLIST,ITMCNT,XACTMAT,ADDANS,OKANS
+21 NEW MINLNG,MAXLNG,PATRN,ADDITM,XTUPCASE
+22 ;
+23 ;Default pattern
IF $GET(PARAMSTR("PATRN"))=""
SET PARAMSTR("PATRN")=".ANP"
+24 ;Set default Min Length
IF +$GET(PARAMSTR("MINLNG"))'>0
SET PARAMSTR("MINLNG")=4
+25 ;Set default Max Length
IF +$GET(PARAMSTR("MAXLNG"))'>0
SET PARAMSTR("MAXLNG")=50
+26 SET MINLNG=PARAMSTR("MINLNG")
+27 SET MAXLNG=PARAMSTR("MAXLNG")
+28 SET PATRN=PARAMSTR("PATRN")
+29 SET ADDITM=$GET(PARAMSTR("ADDITM"))
+30 ;Set default ADDITM
IF +ADDITM=0
SET ADDITM=0
+31 SET XTUPCASE=+$GET(PARAMSTR("XTUPCASE"))
+32 ;
+33 ;Cleanup control chars, leading and trailing spaces in X
DO CLNXEND(.X)
+34 ;
+35 ;Only upper case for user entry
IF +$GET(XTUPCASE)
SET X=$$UP^XLFSTR(X)
SET PATRN=$$UP^XLFSTR(PATRN)
+36 SET XUPPER=$$UP^XLFSTR(X)
+37 ;
+38 ;Count items in SELARY and find matches
+39 SET (XACTMAT,CURITMNM,ITMCNT)=0
+40 FOR
SET CURITMNM=$ORDER(SELARY(CURITMNM))
if CURITMNM=""
QUIT
Begin DoDot:1
+41 SET ITMNMEU=$$UP^XLFSTR($PIECE(SELARY(CURITMNM),"^",1))
+42 SET ITMNMEL=$PIECE(SELARY(CURITMNM),"^",1)
+43 IF ('XACTMAT)
Begin DoDot:2
+44 ; Case doesn't matter
IF +$GET(XTUPCASE)
IF (ITMNMEU)=XUPPER
SET XACTMAT=CURITMNM
+45 ; Case matters
IF '+$GET(XTUPCASE)
IF (ITMNMEL)=X
SET XACTMAT=CURITMNM
End DoDot:2
+46 ; ITEMLIST = match array [case doesn't matter
IF +$GET(XTUPCASE)
IF $EXTRACT(ITMNMEU,1,$LENGTH(XUPPER))=XUPPER
SET ITMCNT=ITMCNT+1
SET ITEMLIST(ITMCNT)=ITMNMEL_"^"_CURITMNM
+47 ; ITEMLIST = match array [case matters]
IF '+$GET(XTUPCASE)
IF $EXTRACT(ITMNMEL,1,$LENGTH(X))=X
SET ITMCNT=ITMCNT+1
SET ITEMLIST(ITMCNT)=ITMNMEL_"^"_CURITMNM
End DoDot:1
+48 ;
+49 ; Present list to user for selection when ITMCNT>1
IF ITMCNT>1
Begin DoDot:1
+50 NEW XVAL,XTOUT
+51 ;Initialize selected Item #
SET XVAL=-1
+52 SET (XTOUT,CURITMNM)=0
+53 ;List items
FOR
SET CURITMNM=$ORDER(ITEMLIST(CURITMNM))
if +CURITMNM=0
QUIT
if XTOUT
QUIT
if ($EXTRACT(XVAL,1)="^")
QUIT
if (XVAL?1.N)
QUIT
Begin DoDot:2
+54 WRITE !," ",CURITMNM,": ",$PIECE(ITEMLIST(CURITMNM),"^")
+55 IF '(CURITMNM#5)!(CURITMNM=ITMCNT)
Begin DoDot:3
+56 FOR
if (CURITMNM'=ITMCNT)
WRITE !,"Press <Enter> to see more items, '^' to exit, OR"
WRITE !,"Choose 1-"_CURITMNM_": "
READ XVAL:DTIME
if '$TEST
SET XTOUT=1
if XTOUT
QUIT
if $EXTRACT(XVAL,1)="^"
QUIT
if XVAL=""
QUIT
if ((XVAL?1.N)&((+XVAL>0)&(+XVAL<(CURITMNM+1))))
QUIT
Begin DoDot:4
+57 IF 'XTOUT
IF ((XVAL'?1.N)!(+XVAL>(CURITMNM))!(+XVAL<1))
if ($EXTRACT(XVAL,1)'="?")
WRITE " ??"
WRITE !,"Select an item from the list [Number 1 - "_CURITMNM_"]",!
End DoDot:4
End DoDot:3
End DoDot:2
+58 ;
+59 ; ^ out
IF $EXTRACT(XVAL,1)="^"
KILL X
+60 ; Timeout
IF XTOUT
SET X=""
+61 ;
+62 IF 'ADDITM
IF 'XTOUT
IF ($EXTRACT(XVAL,1)'="^")
Begin DoDot:2
+63 IF (+XVAL=0)
Begin DoDot:3
+64 ; No item selected, Kill X for return to ^DIR
IF 'XACTMAT
KILL X
+65 IF XACTMAT
Begin DoDot:4
+66 SET OKANS=$$YNCHK^XTVSLAPI(" "_X_" ...OK","YES")
+67 ; X = Exact match entry #
IF OKANS
SET X=XACTMAT
+68 IF 'OKANS
IF ('$PIECE(OKANS,"^",3))
KILL X
+69 ;Timeout
IF 'OKANS
IF ($PIECE(OKANS,"^",3))
SET X=""
End DoDot:4
End DoDot:3
End DoDot:2
+70 ;
+71 IF ADDITM
IF 'XTOUT
IF ($EXTRACT(XVAL,1)'="^")
Begin DoDot:2
+72 IF $PIECE(ADDITM,"^",2)
IF XACTMAT
IF (+XVAL=0)
Begin DoDot:3
+73 ;ASKADD KILLs X on ^ or NO add
DO ASKADD(.ADDANS,.X,.SELARY,.ITEMNUM)
+74 ;Timeout
IF 'ADDANS
IF ($PIECE(ADDANS,"^",3))
SET X=""
End DoDot:3
+75 ;
+76 IF ('$PIECE(ADDITM,"^",2))
IF XACTMAT
IF (+XVAL=0)
KILL X
+77 ;
+78 IF 'XACTMAT
IF (+XVAL=0)
Begin DoDot:3
+79 IF '$$BADENT(MINLNG,MAXLNG,PATRN,.X)
Begin DoDot:4
+80 DO ASKADD(.ADDANS,.X,.SELARY,.ITEMNUM)
+81 ;Timeout
IF 'ADDANS
IF ($PIECE(ADDANS,"^",3))
SET X=""
End DoDot:4
End DoDot:3
End DoDot:2
+82 ;
+83 ; X = SELARY selection #
IF ('XTOUT)
IF (+XVAL>0)
SET X=$PIECE(ITEMLIST(XVAL),"^",2)
End DoDot:1
+84 ;
+85 IF ITMCNT=1
Begin DoDot:1
+86 NEW ONEITMEN,ONEITMNM
+87 SET ONEITMEN=$PIECE(ITEMLIST(1),"^",2)
+88 SET ONEITMNM=$PIECE(ITEMLIST(1),"^",1)
+89 WRITE $EXTRACT(ONEITMNM,$LENGTH(X)+1,$LENGTH(ONEITMNM))
+90 IF ADDITM
Begin DoDot:2
+91 SET OKANS=$$YNCHK^XTVSLAPI(" ...OK","YES")
+92 IF OKANS
SET X=ONEITMEN
+93 ;
+94 ; ^ out
IF 'OKANS
IF ($PIECE(OKANS,"^",2)=-1)
IF ('$PIECE(OKANS,"^",3))
KILL X
+95 IF 'OKANS
IF ('$PIECE(OKANS,"^",2))
IF ('$PIECE(OKANS,"^",3))
IF ('$$BADENT(MINLNG,MAXLNG,PATRN,.X))
Begin DoDot:3
+96 ;Dup's allowed
IF ($PIECE(ADDITM,"^",2))
DO ASKADD(.ADDANS,.X,.SELARY,.ITEMNUM)
+97 IF ('$PIECE(ADDITM,"^",2))
IF ($GET(X)'=ONEITMNM)
DO ASKADD(.ADDANS,.X,.SELARY,.ITEMNUM)
+98 ; No dup's
IF ('$PIECE(ADDITM,"^",2))
IF ($GET(X)=ONEITMNM)
KILL X
End DoDot:3
+99 ;
+100 ; Timeout
IF ($PIECE($GET(OKANS),"^",3))!($PIECE($GET(ADDANS),"^",3))
SET X=""
End DoDot:2
+101 ;
+102 IF 'ADDITM
Begin DoDot:2
+103 SET OKANS=$$YNCHK^XTVSLAPI(" ...OK","YES")
+104 IF OKANS
SET X=ONEITMEN
+105 IF 'OKANS
IF ('$PIECE(OKANS,"^",3))
KILL X
+106 ;Timeout
IF 'OKANS
IF ($PIECE(OKANS,"^",3))
SET X=""
End DoDot:2
End DoDot:1
+107 ;
+108 IF ITMCNT=0
Begin DoDot:1
+109 IF ADDITM
IF '$$BADENT(MINLNG,MAXLNG,PATRN,.X)
Begin DoDot:2
+110 DO ASKADD(.ADDANS,.X,.SELARY,.ITEMNUM)
+111 ; Time out
IF 'ADDANS
IF ($PIECE(ADDANS,"^",3))
SET X=""
End DoDot:2
+112 IF 'ADDITM
KILL X
End DoDot:1
+113 ;
+114 QUIT
+115 ;
ASKADD(ADDANS,X,SELARY,ITEMNUM) ; Query to Add item
+1 SET ADDANS=$$YNCHK^XTVSLAPI(" Are you adding "_X)
+2 IF ADDANS
DO INSRTX^XTVSLAPI(.X,.SELARY,.ITEMNUM)
+3 ; ^ or Not Adding
IF 'ADDANS
IF ('$PIECE(ADDANS,"^",3))
KILL X
+4 QUIT
+5 ;
CLNXEND(XVAL) ; Removes control chars from end & spaces from beginning and end
+1 ; INPUT: XVAL - String to clean up [Passed by reference]
+2 ; (Removes control characters and trailing spaces from a string)
+3 ;
+4 NEW LPCNT,CLNX,CHKCHAR
+5 SET CLNX=X
+6 FOR LPCNT=1:1:$LENGTH(X)
SET CHKCHAR=$ASCII($EXTRACT(X,LPCNT))
if ((CHKCHAR<33)!(CHKCHAR>126))
SET X=$TRANSLATE(X,($EXTRACT(X,LPCNT))," ")
+7 FOR LPCNT=$LENGTH(X):-1:1
SET CHKCHAR=$ASCII($EXTRACT(X,LPCNT))
if ((CHKCHAR>32)&(CHKCHAR<127))
QUIT
SET CLNX=$EXTRACT(X,1,LPCNT-1)
+8 ;
+9 SET LPCNT=0
+10 FOR
SET LPCNT=LPCNT+1
SET CHKCHAR=$ASCII($EXTRACT(CLNX,LPCNT))
if (CHKCHAR'=32)
QUIT
SET CLNX=$EXTRACT(CLNX,LPCNT+1,$LENGTH(CLNX))
+11 ;
+12 SET X=CLNX
+13 QUIT
+14 ;
PTRNDESC(PATRN) ; Pattern Description
+1 ; Returns a description string for type of string
+2 NEW PATDESC,PTRNPARS,PTRNTXT,BEGTXT,ENDTXT
+3 SET (PTRNTXT,PATDESC)=""
+4 ;Change pattern codes to uppercase, not strings in pattern
SET PATRNPARS=$$PTRNEXT(PATRN)
+5 SET BEGTXT=$PIECE(PATRNPARS,"^",3)
+6 SET ENDTXT=$PIECE(PATRNPARS,"^",4)
+7 SET PATRN=$PIECE(PATRNPARS,"^",2)
+8 IF PATRN["A"
SET PATDESC=PATDESC_" Alpha"
+9 IF PATRN["N"
SET PATDESC=PATDESC_$SELECT(PATDESC'["Alpha":" Numeric",1:"-Numeric")
+10 IF PATRN["P"
SET PATDESC=PATDESC_$SELECT((PATDESC'["Alpha")&(PATDESC'["Numeric"):" Punctuation",1:"-Punctuation")
+11 IF BEGTXT]""
SET PTRNTXT=$SELECT(ENDTXT="":" and",1:",")_" begin with '"_BEGTXT_"'"
+12 IF ENDTXT]""
SET PTRNTXT=PTRNTXT_" and end with '"_ENDTXT_"'"
+13 SET PATDESC=PATDESC_PTRNTXT_"."
+14 QUIT PATDESC
+15 ;
PTRNEXT(PATRN) ; Extract PATTERN characters, Change lower case pattern codes to uppercase
+1 ;Return a 4 ^ pce result where:
+2 ; Pce 1 - PATRN with lower case patern codes changed to uppercase
+3 ; Pce 2 - Uppercase Pattern Codes
+4 ; Pce 3 - A string that the item must begin with
+5 ; Pce 4 - A string that the item must end with
+6 ;
+7 NEW PTRNCHRS,QUOTOPEN,POSCTR,CHKCHAR,SETPCHAR,PTRNCODE,PTRNBEG,PTRNEND
+8 SET (PTRNCODE,PTRNCHRS,PTRNBEG,PTRNEND)=""
+9 SET (SETPCHAR,QUOTOPEN)=0
+10 FOR POSCTR=1:1:$LENGTH(PATRN)
Begin DoDot:1
+11 SET CHKCHAR=$EXTRACT(PATRN,POSCTR)
+12 IF CHKCHAR=""""
IF ('QUOTOPEN)
SET (SETPCHAR,QUOTOPEN)=1
SET PTRNCHRS=PTRNCHRS_CHKCHAR
+13 ;
+14 IF CHKCHAR=""""
IF (QUOTOPEN)
IF ('SETPCHAR)
Begin DoDot:2
+15 SET QUOTOPEN=0
+16 SET SETPCHAR=1
+17 SET PTRNCHRS=PTRNCHRS_CHKCHAR
End DoDot:2
+18 ;
+19 IF CHKCHAR'=""""
IF (QUOTOPEN)
IF ('SETPCHAR)
Begin DoDot:2
+20 SET PTRNCHRS=PTRNCHRS_CHKCHAR
+21 if PTRNCODE=""
SET PTRNBEG=PTRNBEG_CHKCHAR
+22 if PTRNCODE'=""
SET PTRNEND=PTRNEND_CHKCHAR
End DoDot:2
+23 ;
+24 IF CHKCHAR'=""""
IF ('QUOTOPEN)
IF ('SETPCHAR)
Begin DoDot:2
+25 SET PTRNCHRS=PTRNCHRS_$$UP^XLFSTR(CHKCHAR)
+26 IF "ANP"[$$UP^XLFSTR(CHKCHAR)
SET PTRNCODE=PTRNCODE_$$UP^XLFSTR(CHKCHAR)
End DoDot:2
+27 SET SETPCHAR=0
End DoDot:1
+28 QUIT PTRNCHRS_"^"_PTRNCODE_"^"_PTRNBEG_"^"_PTRNEND
+29 ;
BADENT(MINLNG,MAXLNG,PATRN,X) ;Evaluate X for String PATTERN and Length req's
+1 ; RESULT : 0 - entry meets requirements
+2 ; 1 - entry doesn't meet requirements
+3 ;
+4 NEW RESULT
+5 SET RESULT=0
+6 IF (($LENGTH(X)<MINLNG)!($LENGTH(X)>MAXLNG)!(X'?@PATRN))
Begin DoDot:1
+7 KILL X
+8 WRITE !," Item must be "_MINLNG_" to "_MAXLNG_" characters made up of...",!," ",$$PTRNDESC(PATRN)
+9 SET RESULT=1
End DoDot:1
+10 QUIT RESULT
