- 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 Feb 19, 2025@00:08:46 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