PXRMINTR ;SLC/PKR/PJH - Input transforms for Clinical Reminders. ;11/04/2013
;;2.0;CLINICAL REMINDERS;**4,12,16,18,26**;Feb 04, 2005;Build 404
;=======================================================
VASP(DA,X) ;Check for valid associate sponsor in file 811.6.
;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
;Make sure that an associated sponsor does not point to itself.
I X=DA D Q 0
. D EN^DDIOL("An associated sponsor cannot point to itself.")
;A sponsor cannot be an associated sponsor if it contains associated
;sponsors.
I $D(^PXRMD(811.6,X,2,"B")) D Q 0
. D EN^DDIOL("A sponsor cannot be selected as an associated sponsor if it contains associated sponsors.")
;The class of an associated sponsor must match that of the sponsor.
N ASCLASS,SCLASS
S SCLASS=$P(^PXRMD(811.6,DA,0),U,2)
S ASCLASS=$P(^PXRMD(811.6,X,0),U,2)
I ASCLASS'=SCLASS D Q 0
. N TEXT
. S TEXT="The associated sponsor's class is "_ASCLASS_", it does not match the sponsor's class which is "_SCLASS_". They must match."
. D EN^DDIOL(TEXT)
Q 1
;
;=======================================================
VCLASS(X) ;Check for valid CLASS field, ordinary users cannot create
;National classes.
;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 (X["N"),(($G(PXRMINST)'=1)!(DUZ(0)'="@")) D Q 0
. D EN^DDIOL("You are not allowed to create a NATIONAL class")
E Q 1
;
;=======================================================
VDT(X) ;Check for a valid date/time. Input transform on
;beginning date/time and ending date/time fields.
N FMDATE,PXRMINTR,VALID
S PXRMINTR=1
;If X is already in internal FileMan format make sure it is valid.
I X?7N0.1"."0.6N D DT^DILF("ST",X,.FMDATE,"","MSG")
I X'?7N0.1"."0.6N S FMDATE=$$CTFMD^PXRMDATE(X)
S VALID=$S(FMDATE=-1:0,1:1)
I 'VALID D
. N TEXT
. S TEXT=X_" is not a valid date/time"
. D EN^DDIOL(TEXT)
Q VALID
;
;=======================================================
VFINDING(X) ;Check X to see if it is a valid finding. This is the input
;transform on the .01 field of the reminder findings multiple for
;definitions and terms.
;Include stubs for all possible finding types in case we need input
;transforms on them.
;I X["AUTTEDT(" Q 1
;I X["AUTTEXAM(" Q 1
I X["AUTTHF(" Q $$VHF(X)
;I X["AUTTIMM(" Q 1
;I X["AUTTSK(" Q 1
;I X["GMRD(120.51," Q 1
I X["LAB(60," Q $$VLAB(X)
;I X["ORD(101.43," Q 1
I X["PXD(811.2," Q $$VTAX(X)
;I X["PXRMD(811.4," Q 1
;I X["PXRMD(811.5," Q 1
;I X["PS(50.605," Q 1
;I X["PSDRUG(" Q 1
;I X["PSNDF(50.6," Q 1
;I X["RAMIS(71," Q 1
;I X["YTT(601," Q 1
Q 1
;
;=======================================================
VFREQ(X) ;Check for a valid frequency. It must be of the form NU,
;where N is an integer and U is unit. The integer can be between
;0 and 9999 inclusive. Valid units are: H (hours),
;D (days), W (weeks), M (months), and Y (years). Used as input
;transform for Baseline Frequency, finding multiple Reminder
;Frequency and called by Custom Date Due input transform.
S X=$$UP^XLFSTR(X)
Q X?1.4N1(1"H",1"D",1"W",1"M",1"Y")
;
;=======================================================
VHF(X) ;Check for valid health factor findings. It must be a factor, not
;a category.
N CAT,IEN,TEMP,TYPE
S IEN=$P(X,";",1)
S TEMP=$G(^AUTTHF(IEN,0))
S TYPE=$P(TEMP,U,10)
I TYPE="C" D Q 0
. D EN^DDIOL("Category health factors cannot be used as a finding!")
I TYPE'="F" D Q 0
. D EN^DDIOL("Only factor health factors can be used as a finding!")
;Make sure that the health factor has a category.
S CAT=$P(TEMP,U,3)
I CAT="" D Q 0
. D EN^DDIOL("Factor health factors must have a category!")
I '$D(^AUTTHF(CAT)) D Q 0
. D EN^DDIOL("The category for this health factor does not exist!")
Q 1
;
;=======================================================
VIGNAC(X) ;Check X to see if it contains valid IGNORE ON N/A codes.
;This is part of the input transform for this field. The length of the
;IGNORE ON N/A field is 8 characters. The valid codes are:
; A - age
; I - inactive
; R - race
; S - sex
; * - wildcard matches anything.
N LEN
S LEN=$L(X)
I (LEN>8)!(LEN<1) Q 0
;
N TEMP,TEXT
S TEMP=X
S TEMP=$TR(TEMP,"A","")
S TEMP=$TR(TEMP,"I","")
S TEMP=$TR(TEMP,"R","")
S TEMP=$TR(TEMP,"S","")
S TEMP=$TR(TEMP,"*","")
;At this point TEMP should be NULL,if it is not then there are
;bad codes.
S LEN=$L(TEMP)
I LEN=1 D Q 0
. S TEXT=TEMP_" is not a valid IGNORE ON N/A code!"
. D EN^DDIOL(TEXT)
I LEN>1 D Q 0
. S TEXT=TEMP_" are not valid IGNORE ON N/A codes!"
. D EN^DDIOL(TEXT)
Q 1
;
;=======================================================
VLAB(X) ;Check for valid lab findings. Everything but a panel is ok.
I X'["LAB(60" Q 1
N DATANAME,LAB0,LABTEST,SUB,TEST,TEXT
S LABTEST=$P(X,";",1)
;DBIA #91-A
S LAB0=^LAB(60,LABTEST,0)
S SUB=$P(LAB0,U,4)
;BB and WK not allowed
I (SUB="BB")!(SUB="WK") D Q 0
. S TEXT=SUB_" tests cannot be used as reminder findings."
. D EN^DDIOL(.TEXT)
;The concept of lab panel only applies to CH tests.
I SUB'["CH" Q 1
S DATANAME=$P(LAB0,U,5)
;If DATA NAME is null then it is a panel.
I DATANAME="" D Q 0
. S TEXT(1)=$P(LAB0,U,1)_" is a lab panel, it cannot be used as a reminder finding!"
. S TEXT(2)="Contact your Lab ADPAC for help"
. D EN^DDIOL(.TEXT)
Q 1
;
;=======================================================
VNAME(NAME) ;Check for a valid .01 value. The names of national reminder
;components start with "VA-" and normal users are not allowed to
;create them.
;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
N AUTH,STEXT,TEXT,VALID
S NAME=$$UP^XLFSTR(NAME)
S VALID=1
I NAME["~" D
. S TEXT="Name cannot contain the ""~"" character."
. D EN^DDIOL(TEXT)
. H 2
. S VALID=0
S STEXT=$E(NAME,1,3)
I (STEXT="VA-") D
. S AUTH=($G(PXRMINST)=1)&(DUZ(0)="@")
. I 'AUTH D
.. S TEXT="Name cannot start with ""VA-"", reserved for national reminder components!"
.. D EN^DDIOL(TEXT)
.. H 2
.. S VALID=0
Q VALID
;
;=======================================================
VPRIOL(X) ;Check for a valid Priority List.
;Do not execute as part of a verify fields.
I $L(X)=0 Q 1
I $G(DIUTIL)="VERIFY FIELDS" Q 1
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q 1
N IND,CHAR,TEXT,VALID
S X=$$UP^XLFSTR(X)
S VALID=1
F IND=1:1:$L(X) D
. S CHAR=$E(X,IND)
. I CHAR?0.1"A"0.1"C"0.1"U" Q
. S VALID=0
. S TEXT=CHAR_" is not valid for the Priority List"
. D EN^DDIOL(TEXT)
Q VALID
;
;=======================================================
;If there is no sponsor don't do the check.
I X="" Q 1
;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
N FCLASS,FILENUM,SCLASS,TEXT,VALID
S VALID=1
I $G(X)="" Q VALID
I $G(DIC)="" Q 0
S FILENUM=+$P(@(DIC_"0)"),U,2)
S FCLASS=$P(@(DIC_DA_",100)"),U,1)
S SCLASS=$P(^PXRMD(811.6,X,100),U,1)
I SCLASS'=FCLASS D
. S FCLASS=$$EXTERNAL^DILFD(FILENUM,100,"",FCLASS)
. S SCLASS=$$EXTERNAL^DILFD(811.6,100,"",SCLASS)
. S TEXT="Sponsor Class is "_SCLASS_", File Class is "_FCLASS_" they must match!"
. D EN^DDIOL(TEXT)
. S VALID=0
Q VALID
;
;=======================================================
VTAX(X) ;Make sure the taxonomy is active.
N IEN,INACTIVE
S IEN=$P(X,";",1)
S INACTIVE=$P(^PXD(811.2,IEN,0),U,6)
I INACTIVE D Q 0
. D EN^DDIOL("This taxonomy is inactive and cannot be selected.")
Q 1
;
;=======================================================
VUSAGE(X) ;Check X to see if it contains valid USAGE codes.
;This is part of the input transform for this field. The length of the
;USAGE field is 10 characters. The valid codes are:
; C - CPRS
; L - Reminder Patient List
; O - Reminder Order Checks
; P - Patient
; R - Reports
; X - Extracts
; * - Wildcard matches anything, except P.
N LEN
S LEN=$L(X)
I (LEN>10)!(LEN<1) Q 0
;
N TEMP,TEXT
S TEMP=$$UP^XLFSTR(X)
S TEMP=$TR(TEMP,"C","")
S TEMP=$TR(TEMP,"L","")
S TEMP=$TR(TEMP,"O","")
S TEMP=$TR(TEMP,"P","")
S TEMP=$TR(TEMP,"R","")
S TEMP=$TR(TEMP,"X","")
S TEMP=$TR(TEMP,"*","")
;At this point TEMP should be NULL,if it is not then there are
;bad codes.
S LEN=$L(TEMP)
I LEN=1 D Q 0
. S TEXT=TEMP_" is not a valid USAGE code!"
. D EN^DDIOL(TEXT)
I LEN>1 D Q 0
. S TEXT=TEMP_" are not valid USAGE codes!"
. D EN^DDIOL(TEXT)
Q 1
;
PXRMINTR ;SLC/PKR/PJH - Input transforms for Clinical Reminders. ;11/04/2013
+1 ;;2.0;CLINICAL REMINDERS;**4,12,16,18,26**;Feb 04, 2005;Build 404
+2 ;=======================================================
VASP(DA,X) ;Check for valid associate sponsor in file 811.6.
+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 ;Make sure that an associated sponsor does not point to itself.
+6 IF X=DA
Begin DoDot:1
+7 DO EN^DDIOL("An associated sponsor cannot point to itself.")
End DoDot:1
QUIT 0
+8 ;A sponsor cannot be an associated sponsor if it contains associated
+9 ;sponsors.
+10 IF $DATA(^PXRMD(811.6,X,2,"B"))
Begin DoDot:1
+11 DO EN^DDIOL("A sponsor cannot be selected as an associated sponsor if it contains associated sponsors.")
End DoDot:1
QUIT 0
+12 ;The class of an associated sponsor must match that of the sponsor.
+13 NEW ASCLASS,SCLASS
+14 SET SCLASS=$PIECE(^PXRMD(811.6,DA,0),U,2)
+15 SET ASCLASS=$PIECE(^PXRMD(811.6,X,0),U,2)
+16 IF ASCLASS'=SCLASS
Begin DoDot:1
+17 NEW TEXT
+18 SET TEXT="The associated sponsor's class is "_ASCLASS_", it does not match the sponsor's class which is "_SCLASS_". They must match."
+19 DO EN^DDIOL(TEXT)
End DoDot:1
QUIT 0
+20 QUIT 1
+21 ;
+22 ;=======================================================
VCLASS(X) ;Check for valid CLASS field, ordinary users cannot create
+1 ;National classes.
+2 ;Do not execute as part of a verify fields.
+3 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT 1
+4 ;Do not execute as part of exchange.
+5 IF $GET(PXRMEXCH)
QUIT 1
+6 IF (X["N")
IF (($GET(PXRMINST)'=1)!(DUZ(0)'="@"))
Begin DoDot:1
+7 DO EN^DDIOL("You are not allowed to create a NATIONAL class")
End DoDot:1
QUIT 0
+8 IF '$TEST
QUIT 1
+9 ;
+10 ;=======================================================
VDT(X) ;Check for a valid date/time. Input transform on
+1 ;beginning date/time and ending date/time fields.
+2 NEW FMDATE,PXRMINTR,VALID
+3 SET PXRMINTR=1
+4 ;If X is already in internal FileMan format make sure it is valid.
+5 IF X?7N0.1"."0.6N
DO DT^DILF("ST",X,.FMDATE,"","MSG")
+6 IF X'?7N0.1"."0.6N
SET FMDATE=$$CTFMD^PXRMDATE(X)
+7 SET VALID=$SELECT(FMDATE=-1:0,1:1)
+8 IF 'VALID
Begin DoDot:1
+9 NEW TEXT
+10 SET TEXT=X_" is not a valid date/time"
+11 DO EN^DDIOL(TEXT)
End DoDot:1
+12 QUIT VALID
+13 ;
+14 ;=======================================================
VFINDING(X) ;Check X to see if it is a valid finding. This is the input
+1 ;transform on the .01 field of the reminder findings multiple for
+2 ;definitions and terms.
+3 ;Include stubs for all possible finding types in case we need input
+4 ;transforms on them.
+5 ;I X["AUTTEDT(" Q 1
+6 ;I X["AUTTEXAM(" Q 1
+7 IF X["AUTTHF("
QUIT $$VHF(X)
+8 ;I X["AUTTIMM(" Q 1
+9 ;I X["AUTTSK(" Q 1
+10 ;I X["GMRD(120.51," Q 1
+11 IF X["LAB(60,"
QUIT $$VLAB(X)
+12 ;I X["ORD(101.43," Q 1
+13 IF X["PXD(811.2,"
QUIT $$VTAX(X)
+14 ;I X["PXRMD(811.4," Q 1
+15 ;I X["PXRMD(811.5," Q 1
+16 ;I X["PS(50.605," Q 1
+17 ;I X["PSDRUG(" Q 1
+18 ;I X["PSNDF(50.6," Q 1
+19 ;I X["RAMIS(71," Q 1
+20 ;I X["YTT(601," Q 1
+21 QUIT 1
+22 ;
+23 ;=======================================================
VFREQ(X) ;Check for a valid frequency. It must be of the form NU,
+1 ;where N is an integer and U is unit. The integer can be between
+2 ;0 and 9999 inclusive. Valid units are: H (hours),
+3 ;D (days), W (weeks), M (months), and Y (years). Used as input
+4 ;transform for Baseline Frequency, finding multiple Reminder
+5 ;Frequency and called by Custom Date Due input transform.
+6 SET X=$$UP^XLFSTR(X)
+7 QUIT X?1.4N1(1"H",1"D",1"W",1"M",1"Y")
+8 ;
+9 ;=======================================================
VHF(X) ;Check for valid health factor findings. It must be a factor, not
+1 ;a category.
+2 NEW CAT,IEN,TEMP,TYPE
+3 SET IEN=$PIECE(X,";",1)
+4 SET TEMP=$GET(^AUTTHF(IEN,0))
+5 SET TYPE=$PIECE(TEMP,U,10)
+6 IF TYPE="C"
Begin DoDot:1
+7 DO EN^DDIOL("Category health factors cannot be used as a finding!")
End DoDot:1
QUIT 0
+8 IF TYPE'="F"
Begin DoDot:1
+9 DO EN^DDIOL("Only factor health factors can be used as a finding!")
End DoDot:1
QUIT 0
+10 ;Make sure that the health factor has a category.
+11 SET CAT=$PIECE(TEMP,U,3)
+12 IF CAT=""
Begin DoDot:1
+13 DO EN^DDIOL("Factor health factors must have a category!")
End DoDot:1
QUIT 0
+14 IF '$DATA(^AUTTHF(CAT))
Begin DoDot:1
+15 DO EN^DDIOL("The category for this health factor does not exist!")
End DoDot:1
QUIT 0
+16 QUIT 1
+17 ;
+18 ;=======================================================
VIGNAC(X) ;Check X to see if it contains valid IGNORE ON N/A codes.
+1 ;This is part of the input transform for this field. The length of the
+2 ;IGNORE ON N/A field is 8 characters. The valid codes are:
+3 ; A - age
+4 ; I - inactive
+5 ; R - race
+6 ; S - sex
+7 ; * - wildcard matches anything.
+8 NEW LEN
+9 SET LEN=$LENGTH(X)
+10 IF (LEN>8)!(LEN<1)
QUIT 0
+11 ;
+12 NEW TEMP,TEXT
+13 SET TEMP=X
+14 SET TEMP=$TRANSLATE(TEMP,"A","")
+15 SET TEMP=$TRANSLATE(TEMP,"I","")
+16 SET TEMP=$TRANSLATE(TEMP,"R","")
+17 SET TEMP=$TRANSLATE(TEMP,"S","")
+18 SET TEMP=$TRANSLATE(TEMP,"*","")
+19 ;At this point TEMP should be NULL,if it is not then there are
+20 ;bad codes.
+21 SET LEN=$LENGTH(TEMP)
+22 IF LEN=1
Begin DoDot:1
+23 SET TEXT=TEMP_" is not a valid IGNORE ON N/A code!"
+24 DO EN^DDIOL(TEXT)
End DoDot:1
QUIT 0
+25 IF LEN>1
Begin DoDot:1
+26 SET TEXT=TEMP_" are not valid IGNORE ON N/A codes!"
+27 DO EN^DDIOL(TEXT)
End DoDot:1
QUIT 0
+28 QUIT 1
+29 ;
+30 ;=======================================================
VLAB(X) ;Check for valid lab findings. Everything but a panel is ok.
+1 IF X'["LAB(60"
QUIT 1
+2 NEW DATANAME,LAB0,LABTEST,SUB,TEST,TEXT
+3 SET LABTEST=$PIECE(X,";",1)
+4 ;DBIA #91-A
+5 SET LAB0=^LAB(60,LABTEST,0)
+6 SET SUB=$PIECE(LAB0,U,4)
+7 ;BB and WK not allowed
+8 IF (SUB="BB")!(SUB="WK")
Begin DoDot:1
+9 SET TEXT=SUB_" tests cannot be used as reminder findings."
+10 DO EN^DDIOL(.TEXT)
End DoDot:1
QUIT 0
+11 ;The concept of lab panel only applies to CH tests.
+12 IF SUB'["CH"
QUIT 1
+13 SET DATANAME=$PIECE(LAB0,U,5)
+14 ;If DATA NAME is null then it is a panel.
+15 IF DATANAME=""
Begin DoDot:1
+16 SET TEXT(1)=$PIECE(LAB0,U,1)_" is a lab panel, it cannot be used as a reminder finding!"
+17 SET TEXT(2)="Contact your Lab ADPAC for help"
+18 DO EN^DDIOL(.TEXT)
End DoDot:1
QUIT 0
+19 QUIT 1
+20 ;
+21 ;=======================================================
VNAME(NAME) ;Check for a valid .01 value. The names of national reminder
+1 ;components start with "VA-" and normal users are not allowed to
+2 ;create them.
+3 ;Do not execute as part of a verify fields.
+4 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT 1
+5 ;Do not execute as part of exchange.
+6 IF $GET(PXRMEXCH)
QUIT 1
+7 NEW AUTH,STEXT,TEXT,VALID
+8 SET NAME=$$UP^XLFSTR(NAME)
+9 SET VALID=1
+10 IF NAME["~"
Begin DoDot:1
+11 SET TEXT="Name cannot contain the ""~"" character."
+12 DO EN^DDIOL(TEXT)
+13 HANG 2
+14 SET VALID=0
End DoDot:1
+15 SET STEXT=$EXTRACT(NAME,1,3)
+16 IF (STEXT="VA-")
Begin DoDot:1
+17 SET AUTH=($GET(PXRMINST)=1)&(DUZ(0)="@")
+18 IF 'AUTH
Begin DoDot:2
+19 SET TEXT="Name cannot start with ""VA-"", reserved for national reminder components!"
+20 DO EN^DDIOL(TEXT)
+21 HANG 2
+22 SET VALID=0
End DoDot:2
End DoDot:1
+23 QUIT VALID
+24 ;
+25 ;=======================================================
VPRIOL(X) ;Check for a valid Priority List.
+1 ;Do not execute as part of a verify fields.
+2 IF $LENGTH(X)=0
QUIT 1
+3 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT 1
+4 ;Do not execute as part of exchange.
+5 IF $GET(PXRMEXCH)
QUIT 1
+6 NEW IND,CHAR,TEXT,VALID
+7 SET X=$$UP^XLFSTR(X)
+8 SET VALID=1
+9 FOR IND=1:1:$LENGTH(X)
Begin DoDot:1
+10 SET CHAR=$EXTRACT(X,IND)
+11 IF CHAR?0.1"A"0.1"C"0.1"U"
QUIT
+12 SET VALID=0
+13 SET TEXT=CHAR_" is not valid for the Priority List"
+14 DO EN^DDIOL(TEXT)
End DoDot:1
+15 QUIT VALID
+16 ;
+17 ;=======================================================
+1 ;If there is no sponsor don't do the check.
+2 IF X=""
QUIT 1
+3 ;Do not execute as part of a verify fields.
+4 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT 1
+5 ;Do not execute as part of exchange.
+6 IF $GET(PXRMEXCH)
QUIT 1
+7 NEW FCLASS,FILENUM,SCLASS,TEXT,VALID
+8 SET VALID=1
+9 IF $GET(X)=""
QUIT VALID
+10 IF $GET(DIC)=""
QUIT 0
+11 SET FILENUM=+$PIECE(@(DIC_"0)"),U,2)
+12 SET FCLASS=$PIECE(@(DIC_DA_",100)"),U,1)
+13 SET SCLASS=$PIECE(^PXRMD(811.6,X,100),U,1)
+14 IF SCLASS'=FCLASS
Begin DoDot:1
+15 SET FCLASS=$$EXTERNAL^DILFD(FILENUM,100,"",FCLASS)
+16 SET SCLASS=$$EXTERNAL^DILFD(811.6,100,"",SCLASS)
+17 SET TEXT="Sponsor Class is "_SCLASS_", File Class is "_FCLASS_" they must match!"
+18 DO EN^DDIOL(TEXT)
+19 SET VALID=0
End DoDot:1
+20 QUIT VALID
+21 ;
+22 ;=======================================================
VTAX(X) ;Make sure the taxonomy is active.
+1 NEW IEN,INACTIVE
+2 SET IEN=$PIECE(X,";",1)
+3 SET INACTIVE=$PIECE(^PXD(811.2,IEN,0),U,6)
+4 IF INACTIVE
Begin DoDot:1
+5 DO EN^DDIOL("This taxonomy is inactive and cannot be selected.")
End DoDot:1
QUIT 0
+6 QUIT 1
+7 ;
+8 ;=======================================================
VUSAGE(X) ;Check X to see if it contains valid USAGE codes.
+1 ;This is part of the input transform for this field. The length of the
+2 ;USAGE field is 10 characters. The valid codes are:
+3 ; C - CPRS
+4 ; L - Reminder Patient List
+5 ; O - Reminder Order Checks
+6 ; P - Patient
+7 ; R - Reports
+8 ; X - Extracts
+9 ; * - Wildcard matches anything, except P.
+10 NEW LEN
+11 SET LEN=$LENGTH(X)
+12 IF (LEN>10)!(LEN<1)
QUIT 0
+13 ;
+14 NEW TEMP,TEXT
+15 SET TEMP=$$UP^XLFSTR(X)
+16 SET TEMP=$TRANSLATE(TEMP,"C","")
+17 SET TEMP=$TRANSLATE(TEMP,"L","")
+18 SET TEMP=$TRANSLATE(TEMP,"O","")
+19 SET TEMP=$TRANSLATE(TEMP,"P","")
+20 SET TEMP=$TRANSLATE(TEMP,"R","")
+21 SET TEMP=$TRANSLATE(TEMP,"X","")
+22 SET TEMP=$TRANSLATE(TEMP,"*","")
+23 ;At this point TEMP should be NULL,if it is not then there are
+24 ;bad codes.
+25 SET LEN=$LENGTH(TEMP)
+26 IF LEN=1
Begin DoDot:1
+27 SET TEXT=TEMP_" is not a valid USAGE code!"
+28 DO EN^DDIOL(TEXT)
End DoDot:1
QUIT 0
+29 IF LEN>1
Begin DoDot:1
+30 SET TEXT=TEMP_" are not valid USAGE codes!"
+31 DO EN^DDIOL(TEXT)
End DoDot:1
QUIT 0
+32 QUIT 1
+33 ;
