AGGWVAL ;VNGT/HS/ALA-AGG Window Validation Program ; 07 Apr 2010 7:05 PM
;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
;
;
VAL(DATA,VFILE,PARMS) ;EP -- AGG WINDOW DATA VALIDATION
;
;Input
; VFILE - The vfile number or name
; PARMS - The parameters being checked for validation
;
NEW UID,II,BQ,LIST,BN,PDATA,NAME,VALUE,HDR,CODN,VALID,VALFLD,BI,VFLD,TYPE,X,RESULT
NEW VFIEN,MSG,HNDLR,IEN,CODE,REVAL
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGWVAL",UID))
K @DATA
S II=0,MSG=""
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGWVAL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S VFILE=$G(VFILE,"") I VFILE="" S BMXSEC="RPC Failed: No Window selected" Q
S VFIEN=$O(^AGG(9009068.3,"B",VFILE,""))
S FILE=$P(^AGG(9009068.3,VFIEN,0),U,2)
;
S @DATA@(II)="I00010RESULT^T00100MSG^T00001HANDLER^I00010IEN^T00008CODE^T00100REVALIDATE"_$C(30)
; Get list of parameters
S PARMS=$G(PARMS,"")
I PARMS="" D
. S LIST="",BN=""
. F S BN=$O(PARMS(BN)) Q:BN="" S LIST=LIST_PARMS(BN)
. K PARMS
. S PARMS=LIST
. K LIST
;
I PARMS="" S II=II+1,@DATA@(II)="1^"_$G(MSG)_U_$G(HNDLR)_U_$G(IEN)_U_$G(CODE)_U_$G(REVAL)_$C(30) G DONE
; Parse parameters
F BQ=1:1:$L(PARMS,$C(28)) D Q:$G(BMXSEC)'=""
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
. I NAME["{"!(NAME["}") S NAME=$$STRIP^XLFSTR(NAME,"{}")
. S @NAME=VALUE
. ; If value is DFN, it exists at the PCC Visit level not individual
. ; V File level.
. I VFILE'=9000010&(NAME="DFN"!(NAME="APCDDATE")) Q
. S CODN=$O(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
. I CODN="" S BMXSEC="RPC Failed: Parameter does not exist for this Window" Q
. I $G(VALID)="" S VALID=$P($G(^AGG(9009068.3,VFIEN,10,CODN,2)),U,2)
. I $G(VALFLD)="" S VALFLD=$P($G(^AGG(9009068.3,VFIEN,10,CODN,2)),U,1)
;
; Check that values exist for all fields needed for the validation
F BI=1:1:$L(VALFLD,";") S VFLD=$P(VALFLD,";",BI) D
. I VFLD["*" S VFLD=$$STRIP^XLFSTR(VFLD,"*") Q
. I VFLD["{"!(VFLD["}") S VFLD=$$STRIP^XLFSTR(VFLD,"{}") Q
. I $G(@VFLD)="" S BMXSEC="RPC Failed: Missing validation value for "_VFLD
I $G(BMXSEC)'="" Q
;
S VALID=$TR(VALID,"~","^"),RESULT=0
; Execute the validation tag
D @VALID
S II=II+1,@DATA@(II)=RESULT_U_$G(MSG)_U_$G(HNDLR)_U_$G(IEN)_U_$G(CODE)_U_$G(REVAL)_$C(30)
; Clean up validation variables
F BI=1:1:$L(VALFLD,";") D
. S VFLD=$P(VALFLD,";",BI),VFLD=$$STRIP^XLFSTR(VFLD,"*"),VFLD=$$STRIP^XLFSTR(VFLD,"+"),VFLD=$$STRIP^XLFSTR(VFLD,"{}")
. K @VFLD
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
;
SSN(ASSN,DFN) ;EP - SSN
;I $G(ASSN)="",$G(NOSSN)="",$$ISREQ^AGGUL2(2,"SSN") S RESULT=-1,MSG="Enter a SSN or a Reason for No SSN" Q
;
NEW DGY,AGGL,VERIFY
S VERIFY=0,RESULT=1
I +$G(DFN)=0,$G(ASSN)="" S RESULT=1 Q
I $G(ASSN)'="",$L(ASSN)<9 S RESULT=-1,MSG="SSN should be 9 characters" Q
I +$G(DFN)'=0,$P(^AUPNPAT(DFN,0),U,23)]"" D
. I $D(^AUTTSSN($P(^AUPNPAT(DFN,0),U,23),0)) D
.. I "V"[$P(^AUTTSSN($P(^AUPNPAT(DFN,0),U,23),0),U) S VERIFY=1
I VERIFY S RESULT=-1,MSG="The SSN has been verified by the SSA and cannot be edited." Q
I $G(ASSN)'="" D Q
. S DGY=$O(^DPT("SSN",ASSN,0)) I DGY="" S RESULT=1 Q
. I DGY>0,DGY'=DFN,$D(^DPT(DGY,0)) S RESULT=-1,MSG="SSN already used by another patient." Q
I $E(ASSN,1,1)=9 S RESULT=-1,MSG="The SSN must not begin with 9" Q
I $E(ASSN,1,3)="000",$E(ASSN,1,5)'="00000" S RESULT=-1,MSG="First three digits cannot be zeros." Q
;
S RESULT=1
Q
;
NOSSN(NOSSN,ASSN,DFN) ;EP
I $G(ASSN)="",$G(NOSSN)="",$$ISREQ^AGGUL2(2,"SSN") S RESULT=-1,MSG="Enter a SSN or a Reason for No SSN" Q
I $G(ASSN)="",$G(NOSSN)'="" S RESULT=1 Q
I $G(ASSN)'="",$G(NOSSN)'="" S RESULT=-1,MSG="Enter a SSN or a Reason for No SSN. You cannot enter both." Q
Q
;
HRN(HRN,DFN) ;EP - HRN
NEW EDFN,LC
S EDFN=$O(^AUPNPAT("D",HRN,""))
I EDFN="" S RESULT=1 Q
I EDFN=DFN S RESULT=1 Q
S LC=0
S LC=$O(^AUPNPAT("D",HRN,EDFN,LC))
; If the location of the patient with the existing same HRN is not the same location
I LC'=DUZ(2) S RESULT=1 Q
S RESULT=-1,MSG="HRN "_HRN_" is already assigned to patient "_$S($P($G(^DPT(EDFN,0)),U)'="":$P($G(^DPT(EDFN,0)),U),1:"UNDEFINED RECORD")
Q
;
IBQ(X,DFN,TBQ,AGGPTCLB) ;EP - Indian Blood Quantum
N RTN,CLBEN
;
;Skip check if classification/beneficiary is not Indian/Alaskan Native
S CLBEN=$O(^AUTTBEN("B","INDIAN/ALASKA NATIVE","")) ;Get Classification IEN
I AGGPTCLB]"",AGGPTCLB'=CLBEN S RESULT=1,MSG="" Q
;
D
. I $L(TBQ)>11!($L(TBQ)<1) K TBQ Q
. I "NF"[$E(TBQ) S TBQ=$S($E(TBQ)="F":"FULL",1:"NONE") Q
. I $E(TBQ)'?1N&(($E(TBQ,1,3)'="UNK")&($E(TBQ,1,3)'="UNS")) K TBQ Q
. I $E(TBQ)="U" S TBQ=$S($E(TBQ,3)="K":"UNKNOWN",1:"UNSPECIFIED") Q
. I TBQ'?1.4N1"/"1.5N K TBQ Q
. I $P(TBQ,"/",1)>$P(TBQ,"/",2)!(+$P(TBQ,"/",2)=0) K TBQ Q
. S:$P(TBQ,"/",1)=$P(TBQ,"/",2) TBQ="FULL" Q
;
D
. I $L(X)>11!($L(X)<1) K X Q
. I "NF"[$E(X) S X=$S($E(X)="F":"FULL",1:"NONE") Q
. I $E(X)'?1N&(($E(X,1,3)'="UNK")&($E(X,1,3)'="UNS")) K X Q
. I $E(X)="U" S X=$S($E(X,3)="K":"UNKNOWN",1:"UNSPECIFIED") Q
. I X'?1.4N1"/"1.5N K X Q
. I $P(X,"/",1)>$P(X,"/",2)!(+$P(X,"/",2)=0) K X Q
. S:$P(X,"/",1)=$P(X,"/",2) X="FULL" Q
;
S RESULT=1
;
;Set up fields to revalidate
S REVAL="AGGPTELG;AGGPTCLB;AGGPTTRI;AGGPTTRQ"
;
I $G(X)="" S RESULT=-1,MSG="Entry not valid" Q
I $G(TBQ)="" Q
;
;Basic Quantum checks
I RESULT=1,"UNKNOWN,NONE,UNSPECIFIED"[X,"UNKOWN,NONE,UNSPECIFIED"'[TBQ D
. S MSG="Quantums are Inconsistent",RESULT=-1,CODE="AGGPTBLQ"
;
I RESULT=1,TBQ="FULL",X'="FULL" D
. S MSG="Quantums are Inconsistent",RESULT=-1,CODE="AGGPTBLQ"
;
;Check to see if main tribal quantum is greater than blood quantum
I RESULT=1,$P($G(^AGFAC(DUZ(2),0)),U,2)="Y" S RTN=$$QUANT^AGGUL2(X,TBQ,0) I $P(RTN,U)=-1 S MSG="The Tribal Quantum cannot be greater than the Indian Blood Quantum",RESULT=-1
Q
;
TBQ(X,DFN,IBQ,AGGPTCLB) ;EP - Tribal Blood Quantum
D TBQ^AGGWVAL1(X,DFN,IBQ,AGGPTCLB)
Q
;
OTQ(X) ;EP - Other Tribe Quantum
D
. I $L(X)>11!($L(X)<1) K X Q
. I "NF"[$E(X) S X=$S($E(X)="F":"FULL",1:"NONE") Q
. I $E(X)'?1N&(($E(X,1,3)'="UNK")&($E(X,1,3)'="UNS")) K X Q
. I $E(X)="U" S X=$S($E(X,3)="K":"UNKNOWN",1:"UNSPECIFIED") Q
. I X'?1.4N1"/"1.5N K X Q
. I $P(X,"/",1)>$P(X,"/",2)!(+$P(X,"/",2)=0) K X Q
. S:$P(X,"/",1)=$P(X,"/",2) X="FULL" Q
;
I $G(X)="" S RESULT=-1,MSG="Entry not valid" Q
S RESULT=1
Q
;
DELIP(CHOICE,RECORD) ;EP - Delete insurance policy
N IN3PB
S IN3PB=$$USED^AGUTILS(CHOICE,"",8,RECORD)
I $L(IN3PB) D Q
.S RESULT=-1,MSG="WARNING: This member has outstanding claims and/or bills!!!"
.S MSG=MSG_" Deleting this member may cause data integrity problems"
.S MSG=MSG_" in the Third Party Billing package!!"
NEW DA,IENS,REL
S DA(1)=CHOICE,DA=RECORD,IENS=$$IENS^DILF(.DA)
S REL=$$GET1^DIQ(9000006.11,IENS,.05,"E")
I REL="SELF" D Q
. S RESULT=-1,MSG="THIS IS THE POLICY HOLDER. IF YOU DELETE THE POLICY HOLDER"
. S MSG=MSG_" THE PRIVATE INSURANCE ELIGIBILITIES OF ALL MEMBERS OF THIS"
. S MSG=MSG_" POLICY WILL BE DELETED INCLUDING THE POLICY HOLDER"
. S MSG=MSG_" DO YOU REALLY WANT TO DO THIS?"
S RESULT=1
Q
;
IMP(VALUE,AUPNDOB) ;EP - Imprecise date validation
S RESULT=1,AUPNDOB=$G(AUPNDOB,"")
I VALUE="B",AUPNDOB'="" S VALUE=AUPNDOB
S VALUE=$$DATE^AGGUL1(VALUE)
I VALUE="" S RESULT=-1,MSG="Invalid date" Q
Q
;
DRDTS(BDT,EDT) ;EP - Daily Reports Date Validation
S RESULT=1
I BDT="",EDT="" Q
I '$D(DT) D DT^DICRW
; beginning date Check
I BDT]"" D Q:(EDT="")!(RESULT=-1)
. S BDT=$P($$DATE^AGGUL1(BDT),".")
. I BDT="" S RESULT=-1,MSG="Must supply Beginning Date." Q
. I BDT>DT S RESULT=-1,MSG="Do not use future dates." Q
; Ending date check
I EDT]"" D Q:(BDT="")!(RESULT=-1)
. S EDT=$P($$DATE^AGGUL1(EDT),".")
. I EDT="" S RESULT=-1,MSG="Must supply Ending Date." Q
. I EDT>DT S RESULT=-1,MSG="Do not use future dates." Q
; compare beginning and edning dates
I BDT>EDT S RESULT=-1,MSG="INVALID ENTRY - The END is before the BEGINNING." Q
Q
;
VET(DFN,AGGPTVET) ;EP - Veteran validation
NEW X,X1,X2,AGGPTDOB
S RESULT=1
I AGGPTVET="N" Q
S AGGPTDOB=$P(^DPT(DFN,0),U,3)
S X1=DT,X2=AGGPTDOB
S X=$E(X1,1,3)-$E(X2,1,3)-($E(X1,4,7)<$E(X2,4,7))
I X<17 S RESULT=-1,MSG="Applicant is TOO YOUNG to be a veteran...ONLY "_X_" YEARS OLD!!"
Q
;
MP(INSPTR,DFN) ; EP - for repeating insurers
I $D(^AUPNPRVT("I",INSPTR,DFN)) S MSG="WARNING: If you proceed you will be ADDING an Insurer that the Patient already has an Eligibility Record for!"
Q
;
NAM(NAME) ; EP - Name validation
NEW DG20NAME,X,ERROR
S RESULT=1
I NAME="" Q
I NAME[", " S RESULT=-1,MSG="No space after the comma" Q
S (DG20NAME,X)=NAME
S (X,DG20NAME)=$$FORMAT^DPTNAME(.DG20NAME,3,35,,,.ERROR)
S AE="",QFL=0
F S AE=$O(ERROR(AE)) Q:AE="" D Q:QFL
. I AE=1 S RESULT=-1,MSG="Name does not contain a comma",QFL=1 Q
. S RESULT=-1,MSG="Name is not in correct format",QFL=1
Q
;
MAI(NAME) ; EP - Maiden name validation
NEW DG20NAME,X,AE ;,ERROR
S RESULT=1
I NAME="" Q
S (DG20NAME,X)=NAME
S (X,DG20NAME)=$$FORMAT^DPTNAME(.DG20NAME,3,35,,2,.ERROR,1)
S AE="",QFL=0
F S AE=$O(ERROR(AE)) Q:AE="" D Q:QFL
. I AE=1 S RESULT=-1,MSG="Name does not contain a comma",QFL=1 Q
. S RESULT=-1,MSG="Name is not in correct format",QFL=1
Q
;
DOB(DOB) ; EP - Date of Birth Validation
S RESULT=1
I $G(DOB)="" Q
S DOB=$$DATE^AGGUL1(DOB)
I DOB<1701231 S RESULT=-1,MSG="Date must be later than 12/31/1870" Q
I DOB>DT S RESULT=-1,MSG="Future dates not valid" Q
Q
;
DOD(DOD,DFN) ; EP - Date of Death validation
S RESULT=1
I $G(DOD)="" Q
S DOD=$$DATE^AGGUL1(DOD)
S DOB=$$GET1^DIQ(2,DFN_",",.03,"I") I DOB="" Q
I DOD>DT S RESULT=-1,MSG="Future dates not valid" Q
I DOD\1<DOB S RESULT=-1,MSG="Date cannot be before Date of Birth ("_$$FMTE^AGGUL1(DOB)_")" Q
Q
;
ELG(AGB,AGTP,AGQT,AGQI,AGEL) ; EP - Eligibility check
D EN^AGGELCHK(AGB,AGTP,AGQT,AGQI,AGEL)
S REVAL=""
Q
;
ELGS(AGB,AGTP,AGQT,AGQI,AGEL) ; EP - Eligibility check from Eligibility Status field
S RESULT="",MSG="",CODE="",REVAL=""
D EN^AGGELCHK(AGB,AGTP,AGQT,AGQI,AGEL)
;
;Determine whether to flag Eligibility Status field with an error
;Errors for other fields will be caught in revalidation
I $G(RESULT)=-1,($G(CODE)="AGGPTCLB"!($G(CODE)="AGGPTTRI")) S RESULT=1,MSG="",CODE=""
;
;Set up fields to revalidate
S REVAL="AGGPTCLB;AGGPTBLQ;AGGPTTRI;AGGPTTRQ"
Q
;
ELGC(AGB,AGTP,AGQT,AGQI,AGEL) ; EP - Eligibility check from Classification field
S RESULT="",MSG="",CODE="",REVAL=""
D EN^AGGELCHK(AGB,AGTP,AGQT,AGQI,AGEL)
;
;Determine whether to flag Classification field with an error
;Errors for other fields will be caught in revalidation
I $G(RESULT)=-1,($G(CODE)="AGGPTELG"!($G(CODE)="AGGPTTRI")) S RESULT=1,MSG="",CODE=""
;
;Set up fields to revalidate
S REVAL="AGGPTELG;AGGPTBLQ;AGGPTTRI;AGGPTTRQ"
Q
;
ELGT(AGB,AGTP,AGQT,AGQI,AGEL) ; EP - Eligibility check from Tribe of Membership field
S RESULT="",MSG="",CODE="",REVAL=""
D EN^AGGELCHK(AGB,AGTP,AGQT,AGQI,AGEL)
;
;Determine whether to flag Tribe of Membership field with an error
;Errors for other fields will be caught in revalidation
I $G(RESULT)=-1,($G(CODE)="AGGPTCLB"!($G(CODE)="AGGPTELG")) S RESULT=1,MSG="",CODE=""
;
;Set up fields to revalidate
S REVAL="AGGPTELG;AGGPTCLB;AGGPTBLQ;AGGPTTRQ"
Q
;
FM(AGGFTNME,AGGMTNME,DFN) ; EP = Family Member check
NEW AGE
S RESULT=1
S AGE=$$AGE^AGGAGE(DFN)
I AGE'<18 Q
;
I $G(AGGFTNME)'="" D NAM(AGGFTNME) I RESULT'=1 Q
I $G(AGGMTNME)'="" D NAM(AGGMTNME) I RESULT'=1 Q
S REVAL="AGGFTEMN;AGGMTEMN;AGGFTNME;AGGMTNME"
I $G(AGGFTNME)="",$G(AGGMTNME)="" S RESULT=-1,MSG="Minor must have either Father's name or Mother's name entered." Q
Q
;
FEMP(AGGFTEMN,AGGMTEMN,AGGFTNME,AGGMTNME,DFN) ; EP = Father's Employer check
D FEMP^AGGWVAL1(AGGFTEMN,AGGMTEMN,AGGFTNME,AGGMTNME,DFN)
Q
;
MEMP(AGGMTEMN,AGGMTNME,AGGFTNME,AGGFTEMN,DFN) ; EP = Mother's Employer check
D MEMP^AGGWVAL1(AGGMTEMN,AGGMTNME,AGGFTNME,AGGFTEMN,DFN)
Q
;
ROI(AGGPTROI) ; EP - Release of Information
N RES
S RESULT=1,MSG=""
S RES=$$ROI^AGGALTRG(AGGPTROI) I $P(RES,U)=-1 S RESULT=-1,MSG=$P(RES,U,2)
Q
;
AOB(AOB) ;EP - Assignment of Benefits
S RESULT=1,MSG=""
S REVAL="AGGPTROI"
I $$RQAOB^AGEDERR4(DUZ(2)),AOB="" S RESULT=-1,MSG="Assignment of Benefits is Required"
Q
;
ZIP(ZIP) ;EP - Zip Code Validation
I $G(ZIP)="" S RESULT=1 Q
S ZIP=$$STRIP^XLFSTR(ZIP,"-")
I $L(ZIP)<5!($L(ZIP)>9) S RESULT=-1,MSG="Enter 5 or 9 digit zip code." Q
I ZIP'?5N,(ZIP'?9N) S RESULT=-1,MSG="Enter numbers for zip code." Q
S RESULT=1
Q
;
DTEMS(STRT,END) ; EP - Elig dates validation for Medicaid and Private Insurance
D DTEMS^AGGARVAL(STRT,END)
Q
;
DTEME(END,STRT) ; EP
D DTEME^AGGARVAL(END,STRT)
Q
;
DTMS(TRANSTYP,STRT,END) ; EP
I TRANSTYP="A" S RESULT=1 Q
D DTEMS^AGGARVAL(STRT,END)
Q
;
DTME(TRANSTYP,END,STRT) ; EP
I TRANSTYP="A" S RESULT=1 Q
D DTEME^AGGARVAL(END,STRT)
Q
;
HNUM(HNUM) ; EP
S RESULT=1
I $G(HNUM)="" Q
I HNUM'?.N S RESULT=-1,MSG="Enter a number between 0 and 99" Q
I HNUM<0!(HNUM>99) S RESULT=-1,MSG="Enter a number between 0 and 99"
Q
;
CERT(DCER) ; EP - Death Certificate
S RESULT=1
I $G(DCER)="" Q
I $L(DCER)>8!($L(DCER)<6)!'(DCER?6.8N) S RESULT=-1,MSG="Death Certificate must be between 6 and 8 numbers only." Q
Q
AGGWVAL ;VNGT/HS/ALA-AGG Window Validation Program ; 07 Apr 2010 7:05 PM
+1 ;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
+2 ;
+3 ;
VAL(DATA,VFILE,PARMS) ;EP -- AGG WINDOW DATA VALIDATION
+1 ;
+2 ;Input
+3 ; VFILE - The vfile number or name
+4 ; PARMS - The parameters being checked for validation
+5 ;
+6 NEW UID,II,BQ,LIST,BN,PDATA,NAME,VALUE,HDR,CODN,VALID,VALFLD,BI,VFLD,TYPE,X,RESULT
+7 NEW VFIEN,MSG,HNDLR,IEN,CODE,REVAL
+8 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+9 SET DATA=$NAME(^TMP("AGGWVAL",UID))
+10 KILL @DATA
+11 SET II=0
SET MSG=""
+12 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGWVAL D UNWIND^%ZTER"
+13 SET VFILE=$GET(VFILE,"")
IF VFILE=""
SET BMXSEC="RPC Failed: No Window selected"
QUIT
+14 SET VFIEN=$ORDER(^AGG(9009068.3,"B",VFILE,""))
+15 SET FILE=$PIECE(^AGG(9009068.3,VFIEN,0),U,2)
+16 ;
+17 SET @DATA@(II)="I00010RESULT^T00100MSG^T00001HANDLER^I00010IEN^T00008CODE^T00100REVALIDATE"_$CHAR(30)
+18 ; Get list of parameters
+19 SET PARMS=$GET(PARMS,"")
+20 IF PARMS=""
Begin DoDot:1
+21 SET LIST=""
SET BN=""
+22 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+23 KILL PARMS
+24 SET PARMS=LIST
+25 KILL LIST
End DoDot:1
+26 ;
+27 IF PARMS=""
SET II=II+1
SET @DATA@(II)="1^"_$GET(MSG)_U_$GET(HNDLR)_U_$GET(IEN)_U_$GET(CODE)_U_$GET(REVAL)_$CHAR(30)
GOTO DONE
+28 ; Parse parameters
+29 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+30 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+31 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+32 IF NAME["{"!(NAME["}")
SET NAME=$$STRIP^XLFSTR(NAME,"{}")
+33 SET @NAME=VALUE
+34 ; If value is DFN, it exists at the PCC Visit level not individual
+35 ; V File level.
+36 IF VFILE'=9000010&(NAME="DFN"!(NAME="APCDDATE"))
QUIT
+37 SET CODN=$ORDER(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
+38 IF CODN=""
SET BMXSEC="RPC Failed: Parameter does not exist for this Window"
QUIT
+39 IF $GET(VALID)=""
SET VALID=$PIECE($GET(^AGG(9009068.3,VFIEN,10,CODN,2)),U,2)
+40 IF $GET(VALFLD)=""
SET VALFLD=$PIECE($GET(^AGG(9009068.3,VFIEN,10,CODN,2)),U,1)
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+41 ;
+42 ; Check that values exist for all fields needed for the validation
+43 FOR BI=1:1:$LENGTH(VALFLD,";")
SET VFLD=$PIECE(VALFLD,";",BI)
Begin DoDot:1
+44 IF VFLD["*"
SET VFLD=$$STRIP^XLFSTR(VFLD,"*")
QUIT
+45 IF VFLD["{"!(VFLD["}")
SET VFLD=$$STRIP^XLFSTR(VFLD,"{}")
QUIT
+46 IF $GET(@VFLD)=""
SET BMXSEC="RPC Failed: Missing validation value for "_VFLD
End DoDot:1
+47 IF $GET(BMXSEC)'=""
QUIT
+48 ;
+49 SET VALID=$TRANSLATE(VALID,"~","^")
SET RESULT=0
+50 ; Execute the validation tag
+51 DO @VALID
+52 SET II=II+1
SET @DATA@(II)=RESULT_U_$GET(MSG)_U_$GET(HNDLR)_U_$GET(IEN)_U_$GET(CODE)_U_$GET(REVAL)_$CHAR(30)
+53 ; Clean up validation variables
+54 FOR BI=1:1:$LENGTH(VALFLD,";")
Begin DoDot:1
+55 SET VFLD=$PIECE(VALFLD,";",BI)
SET VFLD=$$STRIP^XLFSTR(VFLD,"*")
SET VFLD=$$STRIP^XLFSTR(VFLD,"+")
SET VFLD=$$STRIP^XLFSTR(VFLD,"{}")
+56 KILL @VFLD
End DoDot:1
+57 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
+7 ;
SSN(ASSN,DFN) ;EP - SSN
+1 ;I $G(ASSN)="",$G(NOSSN)="",$$ISREQ^AGGUL2(2,"SSN") S RESULT=-1,MSG="Enter a SSN or a Reason for No SSN" Q
+2 ;
+3 NEW DGY,AGGL,VERIFY
+4 SET VERIFY=0
SET RESULT=1
+5 IF +$GET(DFN)=0
IF $GET(ASSN)=""
SET RESULT=1
QUIT
+6 IF $GET(ASSN)'=""
IF $LENGTH(ASSN)<9
SET RESULT=-1
SET MSG="SSN should be 9 characters"
QUIT
+7 IF +$GET(DFN)'=0
IF $PIECE(^AUPNPAT(DFN,0),U,23)]""
Begin DoDot:1
+8 IF $DATA(^AUTTSSN($PIECE(^AUPNPAT(DFN,0),U,23),0))
Begin DoDot:2
+9 IF "V"[$PIECE(^AUTTSSN($PIECE(^AUPNPAT(DFN,0),U,23),0),U)
SET VERIFY=1
End DoDot:2
End DoDot:1
+10 IF VERIFY
SET RESULT=-1
SET MSG="The SSN has been verified by the SSA and cannot be edited."
QUIT
+11 IF $GET(ASSN)'=""
Begin DoDot:1
+12 SET DGY=$ORDER(^DPT("SSN",ASSN,0))
IF DGY=""
SET RESULT=1
QUIT
+13 IF DGY>0
IF DGY'=DFN
IF $DATA(^DPT(DGY,0))
SET RESULT=-1
SET MSG="SSN already used by another patient."
QUIT
End DoDot:1
QUIT
+14 IF $EXTRACT(ASSN,1,1)=9
SET RESULT=-1
SET MSG="The SSN must not begin with 9"
QUIT
+15 IF $EXTRACT(ASSN,1,3)="000"
IF $EXTRACT(ASSN,1,5)'="00000"
SET RESULT=-1
SET MSG="First three digits cannot be zeros."
QUIT
+16 ;
+17 SET RESULT=1
+18 QUIT
+19 ;
NOSSN(NOSSN,ASSN,DFN) ;EP
+1 IF $GET(ASSN)=""
IF $GET(NOSSN)=""
IF $$ISREQ^AGGUL2(2,"SSN")
SET RESULT=-1
SET MSG="Enter a SSN or a Reason for No SSN"
QUIT
+2 IF $GET(ASSN)=""
IF $GET(NOSSN)'=""
SET RESULT=1
QUIT
+3 IF $GET(ASSN)'=""
IF $GET(NOSSN)'=""
SET RESULT=-1
SET MSG="Enter a SSN or a Reason for No SSN. You cannot enter both."
QUIT
+4 QUIT
+5 ;
HRN(HRN,DFN) ;EP - HRN
+1 NEW EDFN,LC
+2 SET EDFN=$ORDER(^AUPNPAT("D",HRN,""))
+3 IF EDFN=""
SET RESULT=1
QUIT
+4 IF EDFN=DFN
SET RESULT=1
QUIT
+5 SET LC=0
+6 SET LC=$ORDER(^AUPNPAT("D",HRN,EDFN,LC))
+7 ; If the location of the patient with the existing same HRN is not the same location
+8 IF LC'=DUZ(2)
SET RESULT=1
QUIT
+9 SET RESULT=-1
SET MSG="HRN "_HRN_" is already assigned to patient "_$SELECT($PIECE($GET(^DPT(EDFN,0)),U)'="":$PIECE($GET(^DPT(EDFN,0)),U),1:"UNDEFINED RECORD")
+10 QUIT
+11 ;
IBQ(X,DFN,TBQ,AGGPTCLB) ;EP - Indian Blood Quantum
+1 NEW RTN,CLBEN
+2 ;
+3 ;Skip check if classification/beneficiary is not Indian/Alaskan Native
+4 ;Get Classification IEN
SET CLBEN=$ORDER(^AUTTBEN("B","INDIAN/ALASKA NATIVE",""))
+5 IF AGGPTCLB]""
IF AGGPTCLB'=CLBEN
SET RESULT=1
SET MSG=""
QUIT
+6 ;
+7 Begin DoDot:1
+8 IF $LENGTH(TBQ)>11!($LENGTH(TBQ)<1)
KILL TBQ
QUIT
+9 IF "NF"[$EXTRACT(TBQ)
SET TBQ=$SELECT($EXTRACT(TBQ)="F":"FULL",1:"NONE")
QUIT
+10 IF $EXTRACT(TBQ)'?1N&(($EXTRACT(TBQ,1,3)'="UNK")&($EXTRACT(TBQ,1,3)'="UNS"))
KILL TBQ
QUIT
+11 IF $EXTRACT(TBQ)="U"
SET TBQ=$SELECT($EXTRACT(TBQ,3)="K":"UNKNOWN",1:"UNSPECIFIED")
QUIT
+12 IF TBQ'?1.4N1"/"1.5N
KILL TBQ
QUIT
+13 IF $PIECE(TBQ,"/",1)>$PIECE(TBQ,"/",2)!(+$PIECE(TBQ,"/",2)=0)
KILL TBQ
QUIT
+14 IF $PIECE(TBQ,"/",1)=$PIECE(TBQ,"/",2)
SET TBQ="FULL"
QUIT
End DoDot:1
+15 ;
+16 Begin DoDot:1
+17 IF $LENGTH(X)>11!($LENGTH(X)<1)
KILL X
QUIT
+18 IF "NF"[$EXTRACT(X)
SET X=$SELECT($EXTRACT(X)="F":"FULL",1:"NONE")
QUIT
+19 IF $EXTRACT(X)'?1N&(($EXTRACT(X,1,3)'="UNK")&($EXTRACT(X,1,3)'="UNS"))
KILL X
QUIT
+20 IF $EXTRACT(X)="U"
SET X=$SELECT($EXTRACT(X,3)="K":"UNKNOWN",1:"UNSPECIFIED")
QUIT
+21 IF X'?1.4N1"/"1.5N
KILL X
QUIT
+22 IF $PIECE(X,"/",1)>$PIECE(X,"/",2)!(+$PIECE(X,"/",2)=0)
KILL X
QUIT
+23 IF $PIECE(X,"/",1)=$PIECE(X,"/",2)
SET X="FULL"
QUIT
End DoDot:1
+24 ;
+25 SET RESULT=1
+26 ;
+27 ;Set up fields to revalidate
+28 SET REVAL="AGGPTELG;AGGPTCLB;AGGPTTRI;AGGPTTRQ"
+29 ;
+30 IF $GET(X)=""
SET RESULT=-1
SET MSG="Entry not valid"
QUIT
+31 IF $GET(TBQ)=""
QUIT
+32 ;
+33 ;Basic Quantum checks
+34 IF RESULT=1
IF "UNKNOWN,NONE,UNSPECIFIED"[X
IF "UNKOWN,NONE,UNSPECIFIED"'[TBQ
Begin DoDot:1
+35 SET MSG="Quantums are Inconsistent"
SET RESULT=-1
SET CODE="AGGPTBLQ"
End DoDot:1
+36 ;
+37 IF RESULT=1
IF TBQ="FULL"
IF X'="FULL"
Begin DoDot:1
+38 SET MSG="Quantums are Inconsistent"
SET RESULT=-1
SET CODE="AGGPTBLQ"
End DoDot:1
+39 ;
+40 ;Check to see if main tribal quantum is greater than blood quantum
+41 IF RESULT=1
IF $PIECE($GET(^AGFAC(DUZ(2),0)),U,2)="Y"
SET RTN=$$QUANT^AGGUL2(X,TBQ,0)
IF $PIECE(RTN,U)=-1
SET MSG="The Tribal Quantum cannot be greater than the Indian Blood Quantum"
SET RESULT=-1
+42 QUIT
+43 ;
TBQ(X,DFN,IBQ,AGGPTCLB) ;EP - Tribal Blood Quantum
+1 DO TBQ^AGGWVAL1(X,DFN,IBQ,AGGPTCLB)
+2 QUIT
+3 ;
OTQ(X) ;EP - Other Tribe Quantum
+1 Begin DoDot:1
+2 IF $LENGTH(X)>11!($LENGTH(X)<1)
KILL X
QUIT
+3 IF "NF"[$EXTRACT(X)
SET X=$SELECT($EXTRACT(X)="F":"FULL",1:"NONE")
QUIT
+4 IF $EXTRACT(X)'?1N&(($EXTRACT(X,1,3)'="UNK")&($EXTRACT(X,1,3)'="UNS"))
KILL X
QUIT
+5 IF $EXTRACT(X)="U"
SET X=$SELECT($EXTRACT(X,3)="K":"UNKNOWN",1:"UNSPECIFIED")
QUIT
+6 IF X'?1.4N1"/"1.5N
KILL X
QUIT
+7 IF $PIECE(X,"/",1)>$PIECE(X,"/",2)!(+$PIECE(X,"/",2)=0)
KILL X
QUIT
+8 IF $PIECE(X,"/",1)=$PIECE(X,"/",2)
SET X="FULL"
QUIT
End DoDot:1
+9 ;
+10 IF $GET(X)=""
SET RESULT=-1
SET MSG="Entry not valid"
QUIT
+11 SET RESULT=1
+12 QUIT
+13 ;
DELIP(CHOICE,RECORD) ;EP - Delete insurance policy
+1 NEW IN3PB
+2 SET IN3PB=$$USED^AGUTILS(CHOICE,"",8,RECORD)
+3 IF $LENGTH(IN3PB)
Begin DoDot:1
+4 SET RESULT=-1
SET MSG="WARNING: This member has outstanding claims and/or bills!!!"
+5 SET MSG=MSG_" Deleting this member may cause data integrity problems"
+6 SET MSG=MSG_" in the Third Party Billing package!!"
End DoDot:1
QUIT
+7 NEW DA,IENS,REL
+8 SET DA(1)=CHOICE
SET DA=RECORD
SET IENS=$$IENS^DILF(.DA)
+9 SET REL=$$GET1^DIQ(9000006.11,IENS,.05,"E")
+10 IF REL="SELF"
Begin DoDot:1
+11 SET RESULT=-1
SET MSG="THIS IS THE POLICY HOLDER. IF YOU DELETE THE POLICY HOLDER"
+12 SET MSG=MSG_" THE PRIVATE INSURANCE ELIGIBILITIES OF ALL MEMBERS OF THIS"
+13 SET MSG=MSG_" POLICY WILL BE DELETED INCLUDING THE POLICY HOLDER"
+14 SET MSG=MSG_" DO YOU REALLY WANT TO DO THIS?"
End DoDot:1
QUIT
+15 SET RESULT=1
+16 QUIT
+17 ;
IMP(VALUE,AUPNDOB) ;EP - Imprecise date validation
+1 SET RESULT=1
SET AUPNDOB=$GET(AUPNDOB,"")
+2 IF VALUE="B"
IF AUPNDOB'=""
SET VALUE=AUPNDOB
+3 SET VALUE=$$DATE^AGGUL1(VALUE)
+4 IF VALUE=""
SET RESULT=-1
SET MSG="Invalid date"
QUIT
+5 QUIT
+6 ;
DRDTS(BDT,EDT) ;EP - Daily Reports Date Validation
+1 SET RESULT=1
+2 IF BDT=""
IF EDT=""
QUIT
+3 IF '$DATA(DT)
DO DT^DICRW
+4 ; beginning date Check
+5 IF BDT]""
Begin DoDot:1
+6 SET BDT=$PIECE($$DATE^AGGUL1(BDT),".")
+7 IF BDT=""
SET RESULT=-1
SET MSG="Must supply Beginning Date."
QUIT
+8 IF BDT>DT
SET RESULT=-1
SET MSG="Do not use future dates."
QUIT
End DoDot:1
IF (EDT="")!(RESULT=-1)
QUIT
+9 ; Ending date check
+10 IF EDT]""
Begin DoDot:1
+11 SET EDT=$PIECE($$DATE^AGGUL1(EDT),".")
+12 IF EDT=""
SET RESULT=-1
SET MSG="Must supply Ending Date."
QUIT
+13 IF EDT>DT
SET RESULT=-1
SET MSG="Do not use future dates."
QUIT
End DoDot:1
IF (BDT="")!(RESULT=-1)
QUIT
+14 ; compare beginning and edning dates
+15 IF BDT>EDT
SET RESULT=-1
SET MSG="INVALID ENTRY - The END is before the BEGINNING."
QUIT
+16 QUIT
+17 ;
VET(DFN,AGGPTVET) ;EP - Veteran validation
+1 NEW X,X1,X2,AGGPTDOB
+2 SET RESULT=1
+3 IF AGGPTVET="N"
QUIT
+4 SET AGGPTDOB=$PIECE(^DPT(DFN,0),U,3)
+5 SET X1=DT
SET X2=AGGPTDOB
+6 SET X=$EXTRACT(X1,1,3)-$EXTRACT(X2,1,3)-($EXTRACT(X1,4,7)<$EXTRACT(X2,4,7))
+7 IF X<17
SET RESULT=-1
SET MSG="Applicant is TOO YOUNG to be a veteran...ONLY "_X_" YEARS OLD!!"
+8 QUIT
+9 ;
MP(INSPTR,DFN) ; EP - for repeating insurers
+1 IF $DATA(^AUPNPRVT("I",INSPTR,DFN))
SET MSG="WARNING: If you proceed you will be ADDING an Insurer that the Patient already has an Eligibility Record for!"
+2 QUIT
+3 ;
NAM(NAME) ; EP - Name validation
+1 NEW DG20NAME,X,ERROR
+2 SET RESULT=1
+3 IF NAME=""
QUIT
+4 IF NAME[", "
SET RESULT=-1
SET MSG="No space after the comma"
QUIT
+5 SET (DG20NAME,X)=NAME
+6 SET (X,DG20NAME)=$$FORMAT^DPTNAME(.DG20NAME,3,35,,,.ERROR)
+7 SET AE=""
SET QFL=0
+8 FOR
SET AE=$ORDER(ERROR(AE))
IF AE=""
QUIT
Begin DoDot:1
+9 IF AE=1
SET RESULT=-1
SET MSG="Name does not contain a comma"
SET QFL=1
QUIT
+10 SET RESULT=-1
SET MSG="Name is not in correct format"
SET QFL=1
End DoDot:1
IF QFL
QUIT
+11 QUIT
+12 ;
MAI(NAME) ; EP - Maiden name validation
+1 ;,ERROR
NEW DG20NAME,X,AE
+2 SET RESULT=1
+3 IF NAME=""
QUIT
+4 SET (DG20NAME,X)=NAME
+5 SET (X,DG20NAME)=$$FORMAT^DPTNAME(.DG20NAME,3,35,,2,.ERROR,1)
+6 SET AE=""
SET QFL=0
+7 FOR
SET AE=$ORDER(ERROR(AE))
IF AE=""
QUIT
Begin DoDot:1
+8 IF AE=1
SET RESULT=-1
SET MSG="Name does not contain a comma"
SET QFL=1
QUIT
+9 SET RESULT=-1
SET MSG="Name is not in correct format"
SET QFL=1
End DoDot:1
IF QFL
QUIT
+10 QUIT
+11 ;
DOB(DOB) ; EP - Date of Birth Validation
+1 SET RESULT=1
+2 IF $GET(DOB)=""
QUIT
+3 SET DOB=$$DATE^AGGUL1(DOB)
+4 IF DOB<1701231
SET RESULT=-1
SET MSG="Date must be later than 12/31/1870"
QUIT
+5 IF DOB>DT
SET RESULT=-1
SET MSG="Future dates not valid"
QUIT
+6 QUIT
+7 ;
DOD(DOD,DFN) ; EP - Date of Death validation
+1 SET RESULT=1
+2 IF $GET(DOD)=""
QUIT
+3 SET DOD=$$DATE^AGGUL1(DOD)
+4 SET DOB=$$GET1^DIQ(2,DFN_",",.03,"I")
IF DOB=""
QUIT
+5 IF DOD>DT
SET RESULT=-1
SET MSG="Future dates not valid"
QUIT
+6 IF DOD\1<DOB
SET RESULT=-1
SET MSG="Date cannot be before Date of Birth ("_$$FMTE^AGGUL1(DOB)_")"
QUIT
+7 QUIT
+8 ;
ELG(AGB,AGTP,AGQT,AGQI,AGEL) ; EP - Eligibility check
+1 DO EN^AGGELCHK(AGB,AGTP,AGQT,AGQI,AGEL)
+2 SET REVAL=""
+3 QUIT
+4 ;
ELGS(AGB,AGTP,AGQT,AGQI,AGEL) ; EP - Eligibility check from Eligibility Status field
+1 SET RESULT=""
SET MSG=""
SET CODE=""
SET REVAL=""
+2 DO EN^AGGELCHK(AGB,AGTP,AGQT,AGQI,AGEL)
+3 ;
+4 ;Determine whether to flag Eligibility Status field with an error
+5 ;Errors for other fields will be caught in revalidation
+6 IF $GET(RESULT)=-1
IF ($GET(CODE)="AGGPTCLB"!($GET(CODE)="AGGPTTRI"))
SET RESULT=1
SET MSG=""
SET CODE=""
+7 ;
+8 ;Set up fields to revalidate
+9 SET REVAL="AGGPTCLB;AGGPTBLQ;AGGPTTRI;AGGPTTRQ"
+10 QUIT
+11 ;
ELGC(AGB,AGTP,AGQT,AGQI,AGEL) ; EP - Eligibility check from Classification field
+1 SET RESULT=""
SET MSG=""
SET CODE=""
SET REVAL=""
+2 DO EN^AGGELCHK(AGB,AGTP,AGQT,AGQI,AGEL)
+3 ;
+4 ;Determine whether to flag Classification field with an error
+5 ;Errors for other fields will be caught in revalidation
+6 IF $GET(RESULT)=-1
IF ($GET(CODE)="AGGPTELG"!($GET(CODE)="AGGPTTRI"))
SET RESULT=1
SET MSG=""
SET CODE=""
+7 ;
+8 ;Set up fields to revalidate
+9 SET REVAL="AGGPTELG;AGGPTBLQ;AGGPTTRI;AGGPTTRQ"
+10 QUIT
+11 ;
ELGT(AGB,AGTP,AGQT,AGQI,AGEL) ; EP - Eligibility check from Tribe of Membership field
+1 SET RESULT=""
SET MSG=""
SET CODE=""
SET REVAL=""
+2 DO EN^AGGELCHK(AGB,AGTP,AGQT,AGQI,AGEL)
+3 ;
+4 ;Determine whether to flag Tribe of Membership field with an error
+5 ;Errors for other fields will be caught in revalidation
+6 IF $GET(RESULT)=-1
IF ($GET(CODE)="AGGPTCLB"!($GET(CODE)="AGGPTELG"))
SET RESULT=1
SET MSG=""
SET CODE=""
+7 ;
+8 ;Set up fields to revalidate
+9 SET REVAL="AGGPTELG;AGGPTCLB;AGGPTBLQ;AGGPTTRQ"
+10 QUIT
+11 ;
FM(AGGFTNME,AGGMTNME,DFN) ; EP = Family Member check
+1 NEW AGE
+2 SET RESULT=1
+3 SET AGE=$$AGE^AGGAGE(DFN)
+4 IF AGE'<18
QUIT
+5 ;
+6 IF $GET(AGGFTNME)'=""
DO NAM(AGGFTNME)
IF RESULT'=1
QUIT
+7 IF $GET(AGGMTNME)'=""
DO NAM(AGGMTNME)
IF RESULT'=1
QUIT
+8 SET REVAL="AGGFTEMN;AGGMTEMN;AGGFTNME;AGGMTNME"
+9 IF $GET(AGGFTNME)=""
IF $GET(AGGMTNME)=""
SET RESULT=-1
SET MSG="Minor must have either Father's name or Mother's name entered."
QUIT
+10 QUIT
+11 ;
FEMP(AGGFTEMN,AGGMTEMN,AGGFTNME,AGGMTNME,DFN) ; EP = Father's Employer check
+1 DO FEMP^AGGWVAL1(AGGFTEMN,AGGMTEMN,AGGFTNME,AGGMTNME,DFN)
+2 QUIT
+3 ;
MEMP(AGGMTEMN,AGGMTNME,AGGFTNME,AGGFTEMN,DFN) ; EP = Mother's Employer check
+1 DO MEMP^AGGWVAL1(AGGMTEMN,AGGMTNME,AGGFTNME,AGGFTEMN,DFN)
+2 QUIT
+3 ;
ROI(AGGPTROI) ; EP - Release of Information
+1 NEW RES
+2 SET RESULT=1
SET MSG=""
+3 SET RES=$$ROI^AGGALTRG(AGGPTROI)
IF $PIECE(RES,U)=-1
SET RESULT=-1
SET MSG=$PIECE(RES,U,2)
+4 QUIT
+5 ;
AOB(AOB) ;EP - Assignment of Benefits
+1 SET RESULT=1
SET MSG=""
+2 SET REVAL="AGGPTROI"
+3 IF $$RQAOB^AGEDERR4(DUZ(2))
IF AOB=""
SET RESULT=-1
SET MSG="Assignment of Benefits is Required"
+4 QUIT
+5 ;
ZIP(ZIP) ;EP - Zip Code Validation
+1 IF $GET(ZIP)=""
SET RESULT=1
QUIT
+2 SET ZIP=$$STRIP^XLFSTR(ZIP,"-")
+3 IF $LENGTH(ZIP)<5!($LENGTH(ZIP)>9)
SET RESULT=-1
SET MSG="Enter 5 or 9 digit zip code."
QUIT
+4 IF ZIP'?5N
IF (ZIP'?9N)
SET RESULT=-1
SET MSG="Enter numbers for zip code."
QUIT
+5 SET RESULT=1
+6 QUIT
+7 ;
DTEMS(STRT,END) ; EP - Elig dates validation for Medicaid and Private Insurance
+1 DO DTEMS^AGGARVAL(STRT,END)
+2 QUIT
+3 ;
DTEME(END,STRT) ; EP
+1 DO DTEME^AGGARVAL(END,STRT)
+2 QUIT
+3 ;
DTMS(TRANSTYP,STRT,END) ; EP
+1 IF TRANSTYP="A"
SET RESULT=1
QUIT
+2 DO DTEMS^AGGARVAL(STRT,END)
+3 QUIT
+4 ;
DTME(TRANSTYP,END,STRT) ; EP
+1 IF TRANSTYP="A"
SET RESULT=1
QUIT
+2 DO DTEME^AGGARVAL(END,STRT)
+3 QUIT
+4 ;
HNUM(HNUM) ; EP
+1 SET RESULT=1
+2 IF $GET(HNUM)=""
QUIT
+3 IF HNUM'?.N
SET RESULT=-1
SET MSG="Enter a number between 0 and 99"
QUIT
+4 IF HNUM<0!(HNUM>99)
SET RESULT=-1
SET MSG="Enter a number between 0 and 99"
+5 QUIT
+6 ;
CERT(DCER) ; EP - Death Certificate
+1 SET RESULT=1
+2 IF $GET(DCER)=""
QUIT
+3 IF $LENGTH(DCER)>8!($LENGTH(DCER)<6)!'(DCER?6.8N)
SET RESULT=-1
SET MSG="Death Certificate must be between 6 and 8 numbers only."
QUIT
+4 QUIT
