BQIVFVAL ;PRXM/HC/ALA-Validate VFILE data ; 10 Apr 2007 12:56 PM
;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17
Q
;
VAL(DATA,VDEF,PARMS) ;EP -- BQI VFILE DATA VALIDATION
;
;Input
; VDEF - The vdefinition name
; 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
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIVFVAL",UID))
K @DATA
S II=0,MSG=""
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIVFVAL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S VDEF=$G(VDEF,"") I VDEF="" S BMXSEC="No VDef selected" Q
S VFIEN=$$FIND1^DIC(90506.3,"","MOX",VDEF,"","","ERROR")
S VFILE=$P(^BQI(90506.3,VFIEN,0),U,2)
;S VFILE=$G(VFILE,"") I VFILE="" S BMXSEC="No Vfile selected" Q
;S VFIEN=$$FIND1^DIC(90506.3,"","MO",VFILE,"","","ERROR")
;
S @DATA@(II)="I00010RESULT^T00100MSG^T00001HANDLER^I00010IEN"_$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)_$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)
. S @NAME=VALUE
. ; If value is BQIDFN, it exists at the PCC Visit level not individual
. ; V File level.
. I VFILE'=9000010&(NAME="BQIDFN"!(NAME="APCDDATE")) Q
. S CODN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
. I CODN="" S BMXSEC="Parameter does not exist for this Vfile" Q
. I $G(VALID)="" S VALID=$P($G(^BQI(90506.3,VFIEN,10,CODN,2)),U,2)
. I $G(VALFLD)="" S VALFLD=$P($G(^BQI(90506.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 $G(@VFLD)="" S BMXSEC="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)_$C(30)
; Clean up validation variables
F BI=1:1:$L(VALFLD,";") D
. S VFLD=$P(VALFLD,";",BI),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
;
MSR(TYPE,X) ;EP - Measurement validation
; Input
; TYPE = Measurement choice (APCDTTYP)
; X = value of the measurement (APCDTVAL)
;
NEW BQIXTYP,TTYPE,EXEC
S TTYPE=TYPE
;I TYPE?.N S TTYPE=$P(^AUTTMSR(TYPE,0),U,1)
;S BQIXTYP=TTYPE_"^AUPNVMSR"
S EXEC=$G(^AUTTMSR(TYPE,12))
I EXEC'="" X EXEC
;D @BQIXTYP
I $G(X)="" S RESULT=-1 Q
S RESULT=1
Q
;
SKT(RESLT,READ) ;EP - Skin Test
; Input
; RESLT - Result (APCDTRES)
; READ - Reading (APCDTREA)
; Output
; RESULT=-1 didn't pass validation
; RESULT=1 passed validation
;
; Only check validation if both values are populated
I $G(RESLT)=""!($G(READ)="") S RESULT=1 Q
;
; If result is 'Negative' and result is greater than 10
I $G(RESLT)="N"&($G(READ)>10) S RESULT=-1 Q
;
I $G(RESLT)'="P"&($G(READ)>10) S RESULT=-1 Q
;
S RESULT=1
Q
;
EXM(EXAM,RESLT) ;EP - Exam result
; Input
; EXAM - Exam Type
; RESLT - The entered result
;
I EXAM'?.N S EXAM=$$FIND1^DIC(9999999.15,"","B",EXAM,"","","ERROR")
NEW C
S C=$P(^AUTTEXAM(EXAM,0),U,2)
I RESLT="PA",C'=34 S RESULT=-1 Q
I RESLT="PR",C'=34 S RESULT=-1 Q
I RESLT="A",C=34 S RESULT=-1 Q
I RESLT="A",C=35 S RESULT=-1 Q
I RESLT="A",C=36 S RESULT=-1 Q
I RESLT="PO",(C'=35&(C'=36)) S RESULT=-1 Q
S RESULT=1
Q
;
LAB(TEST,RESLT) ;EP - Lab Result
; Input
; TEST - Lab Test IEN
; RESLT - The entered result
;
; Take out validation for a lab result for historical entry
; Allow them to enter anything they please
S RESULT=1
Q
NEW WHERE,LDATA,X
S WHERE=$P(^LAB(60,TEST,0),U,12)
I WHERE="" S RESULT=1 Q
S LDATA=U_WHERE_"0)"
S EXEC=$P(@LDATA,U,5,99)
S X=RESLT X EXEC
I $G(X)="" S RESULT=-1 Q
S RESULT=1
Q
;
LOC(LOC) ; EP - Location
; Input
; Location IEN
S RESULT=1
I $E($$GET1^DIQ(4,LOC_",",.01,"E"),1,5)="OTHER" D
. I $P($G(^APCDSITE(DUZ(2),0)),U,16)'="Y" S RESULT=-1,MSG="Your site parameters file does not indicate outside location can be entered!" Q
Q
;
VDT(VDAT,DFN) ; EP - Visit Date
; Input
; VDAT - Visit date from APCDDATE
; DFN - Patient IEN
S RESULT=1
S DOB=$$GET1^DIQ(2,DFN_",",.03,"I")
S DOD=$$GET1^DIQ(2,DFN_",",.351,"I")
S VDAT=$$DATE^BQIUL1(VDAT)
;
I VDAT\1>DT S RESULT=-1,MSG="Future dates not valid" Q
I VDAT\1<DOB S RESULT=-1,MSG="Date cannot be before Date of Birth ("_$$FMTE^BQIUL1(DOB)_")" Q
I DOD'="" D
. I VDAT\1>DOD S RESULT=-1,MSG="Date cannot be after Date of Death ("_$$FMTE^BQIUL1(DOD)_")" Q
Q
;
PDT(PDAT,VDAT,DFN) ; EP - Procedure Date
; Input
; PDAT - Procedure date
; VDAT - Visit date from APCDDATE
; DFN - Patient IEN
S RESULT=1
S DOB=$$GET1^DIQ(2,DFN_",",.03,"I")
S DOD=$$GET1^DIQ(2,DFN_",",.351,"I")
S VDAT=$$DATE^BQIUL1(VDAT)
S PDAT=$$DATE^BQIUL1(PDAT)
;
I PDAT<(VDAT\1) S RESULT=-1,MSG="Procedure date cannot be before Visit date" Q
I PDAT\1>DT S RESULT=-1,MSG="Future dates not valid" Q
I PDAT\1<DOB S RESULT=-1,MSG="Date cannot be before Date of Birth ("_$$FMTE^BQIUL1(DOB)_")" Q
I DOD'="" D
. I PDAT\1>DOD S RESULT=-1,MSG="Date cannot be after Date of Death ("_$$FMTE^BQIUL1(DOD)_")" Q
Q
;
EPRV(APCDTPRO) ; EP - Education Provider
S RESULT=1
I $P($G(^VA(200,APCDTPRO,"PS")),U,4)'="" S RESULT=-1,MSG="The provider you selected is not an authorized provider for Patient Education entries."
Q
;
HIVDT(DFN,BKMDXDT,BKMAIDT) ; EP - Initial HIV DX Date
NEW X,AIDSDT,DOB,BKMIEN,BKMREG,BKMIENS,DA
S RESULT=1
I BKMDXDT="",BKMAIDT="" Q
S BKMIEN=$$BKMIEN^BKMIXX3(DFN)
S BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
S DA(1)=BKMIEN,DA=BKMREG
S BKMIENS=$$IENS^DILF(.DA)
S AIDSDT=$$DATE^BQIUL1($G(BKMAIDT))
; $$GET1^DIQ(90451.01,BKMIENS,5.5,"I"))
S DOB=$$GET1^DIQ(2,DFN,.03,"I")
S X=$$DATE^BQIUL1(BKMDXDT)
I DOB>X S RESULT=-1,MSG="Date cannot be before Date of Birth ("_$$FMTE^BQIUL1(DOB)_")" Q
I X>DT S RESULT=-1,MSG="Future dates not valid" Q
I AIDSDT'="",X>AIDSDT S RESULT=-1,MSG="Initial HIV DX Date cannot be later than Initial AIDS DX Date" Q
Q
;
AIDDT(DFN,BKMAIDT,BKMDXDT) ; EP - Initial AIDS DX Date
NEW X,HIVDT,DOB,BKMIEN,BKMREG,BKMIENS,DA
S RESULT=1
I BKMAIDT="",BKMDXDT="" Q
S BKMIEN=$$BKMIEN^BKMIXX3(DFN)
S BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
S DA(1)=BKMIEN,DA=BKMREG
S BKMIENS=$$IENS^DILF(.DA)
S HIVDT=$$DATE^BQIUL1($G(BKMDXDT))
;$$GET1^DIQ(90451.01,BKMIENS,5,"I")
S DOB=$$GET1^DIQ(2,DFN,.03,"I")
S X=$$DATE^BQIUL1(BKMAIDT)
I DOB>X S RESULT=-1,MSG="Date cannot be before Date of Birth ("_$$FMTE^BQIUL1(DOB)_")" Q
I X>DT S RESULT=-1,MSG="Future dates not valid" Q
I HIVDT'="",X<HIVDT S RESULT=-1,MSG="Initial AIDS DX Date cannot be before the Initial HIV DX Date"
Q
;
RDT(SKRDT) ; EP - Skin Test Reading Date
S SKRDT=$$DATE^BQIUL1($G(SKRDT))
I SKRDT\1>DT S RESULT=-1,MSG="Future dates not valid" Q
S RESULT=1
Q
;
BDT(VDAT,DFN) ; EP - Problem Date of Onset
; Input
; VDAT - Visit date from APCDDATE
; DFN - Patient IEN
S RESULT=1
I VDAT="" Q
S DOB=$$GET1^DIQ(2,DFN_",",.03,"I")
S DOD=$$GET1^DIQ(2,DFN_",",.351,"I")
S VDAT=$$DATE^BQIUL1(VDAT)
;
I VDAT\1>DT S RESULT=-1,MSG="Future dates not valid" Q
I VDAT\1<DOB S RESULT=-1,MSG="Date cannot be before Date of Birth ("_$$FMTE^BQIUL1(DOB)_")" Q
I DOD'="" D
. I VDAT\1>DOD S RESULT=-1,MSG="Date cannot be after Date of Death ("_$$FMTE^BQIUL1(DOD)_")" Q
Q
;
CLAS(DX,CLS) ; EP - Classification validation
I $$VERSION^XPDUTL("BJPC")<2.0 S RESULT=1 Q
NEW X,BQA,TX,LW,HG
I CLS="" S RESULT=1 Q
S X=CLS
S BQA=0 F S BQA=$O(^APCDPLCL(BQA)) Q:BQA'=+BQA!('$D(X)) D
. S TX=$P(^APCDPLCL(BQA,0),U,2)
. Q:TX=""
. Q:'$D(^ATXAX(TX))
. Q:'$$ICD^ATXCHK(DX,TX,9) ;not in this taxonomy
. S LW=$P(^APCDPLCL(BQA,0),U,3)
. S HG=$P(^APCDPLCL(BQA,0),U,4)
. I X<LW!(X>HG) K X
. Q
I $G(X)="" S RESULT=-1,MSG="Invalid selection" Q
S RESULT=1
Q
;
TXNM(AMQQTNAR) ; EP - Taxonomy name validation
NEW AMQN
S RESULT=1
I AMQQTNAR="" S RESULT=-1,MSG="No name provided" Q
I $D(^ATXAX("B",AMQQTNAR))>0 D Q
. S AMQN=$O(^ATXAX("B",AMQQTNAR,""))
. I DUZ'=$P(^ATXAX(AMQN,0),U,5) S RESULT=-1,MSG="Name already exists and cannot be overwritten except by its creator." Q
. S RESULT=-1,MSG="Replace existing taxonomy with this one?",HNDLR="O" Q
Q
;
CPT(VDAT,NCPT) ; EP - CPT Code validation
S RESULT=1
S VDAT=$$DATE^BQIUL1(VDAT)
I NCPT="" S RESULT=-1,MSG="No CPT code provided" Q
I $P($$CPT^ICPTCOD(NCPT,VDAT),U,7)=0 S RESULT=-1,MSG="CPT Code not valid for this visit date" Q
Q
;
IMP(VALUE) ; EP - Imprecise date validation
S RESULT=1
S VALUE=$$DATE^BQIUL1(VALUE)
I VALUE="" S RESULT=-1,MSG="Invalid date" Q
Q
BQIVFVAL ;PRXM/HC/ALA-Validate VFILE data ; 10 Apr 2007 12:56 PM
+1 ;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17
+2 QUIT
+3 ;
VAL(DATA,VDEF,PARMS) ;EP -- BQI VFILE DATA VALIDATION
+1 ;
+2 ;Input
+3 ; VDEF - The vdefinition name
+4 ; VFILE - The vfile number or name
+5 ; PARMS - The parameters being checked for validation
+6 ;
+7 NEW UID,II,BQ,LIST,BN,PDATA,NAME,VALUE,HDR,CODN,VALID,VALFLD,BI,VFLD,TYPE,X,RESULT
+8 NEW VFIEN,MSG,HNDLR,IEN
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BQIVFVAL",UID))
+11 KILL @DATA
+12 SET II=0
SET MSG=""
+13 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIVFVAL D UNWIND^%ZTER"
+14 SET VDEF=$GET(VDEF,"")
IF VDEF=""
SET BMXSEC="No VDef selected"
QUIT
+15 SET VFIEN=$$FIND1^DIC(90506.3,"","MOX",VDEF,"","","ERROR")
+16 SET VFILE=$PIECE(^BQI(90506.3,VFIEN,0),U,2)
+17 ;S VFILE=$G(VFILE,"") I VFILE="" S BMXSEC="No Vfile selected" Q
+18 ;S VFIEN=$$FIND1^DIC(90506.3,"","MO",VFILE,"","","ERROR")
+19 ;
+20 SET @DATA@(II)="I00010RESULT^T00100MSG^T00001HANDLER^I00010IEN"_$CHAR(30)
+21 ; Get list of parameters
+22 SET PARMS=$GET(PARMS,"")
+23 IF PARMS=""
Begin DoDot:1
+24 SET LIST=""
SET BN=""
+25 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+26 KILL PARMS
+27 SET PARMS=LIST
+28 KILL LIST
End DoDot:1
+29 ;
+30 IF PARMS=""
SET II=II+1
SET @DATA@(II)="1^"_$GET(MSG)_U_$GET(HNDLR)_U_$GET(IEN)_$CHAR(30)
GOTO DONE
+31 ; Parse parameters
+32 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+33 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+34 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+35 SET @NAME=VALUE
+36 ; If value is BQIDFN, it exists at the PCC Visit level not individual
+37 ; V File level.
+38 IF VFILE'=9000010&(NAME="BQIDFN"!(NAME="APCDDATE"))
QUIT
+39 SET CODN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+40 IF CODN=""
SET BMXSEC="Parameter does not exist for this Vfile"
QUIT
+41 IF $GET(VALID)=""
SET VALID=$PIECE($GET(^BQI(90506.3,VFIEN,10,CODN,2)),U,2)
+42 IF $GET(VALFLD)=""
SET VALFLD=$PIECE($GET(^BQI(90506.3,VFIEN,10,CODN,2)),U,1)
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+43 ;
+44 ; Check that values exist for all fields needed for the validation
+45 FOR BI=1:1:$LENGTH(VALFLD,";")
SET VFLD=$PIECE(VALFLD,";",BI)
Begin DoDot:1
+46 IF VFLD["*"
SET VFLD=$$STRIP^XLFSTR(VFLD,"*")
QUIT
+47 IF $GET(@VFLD)=""
SET BMXSEC="Missing validation value for "_VFLD
End DoDot:1
+48 IF $GET(BMXSEC)'=""
QUIT
+49 ;
+50 SET VALID=$TRANSLATE(VALID,"~","^")
SET RESULT=0
+51 ; Execute the validation tag
+52 DO @VALID
+53 SET II=II+1
SET @DATA@(II)=RESULT_U_$GET(MSG)_U_$GET(HNDLR)_U_$GET(IEN)_$CHAR(30)
+54 ; Clean up validation variables
+55 FOR BI=1:1:$LENGTH(VALFLD,";")
Begin DoDot:1
+56 SET VFLD=$PIECE(VALFLD,";",BI)
SET VFLD=$$STRIP^XLFSTR(VFLD,"*")
+57 KILL @VFLD
End DoDot:1
+58 ;
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 ;
MSR(TYPE,X) ;EP - Measurement validation
+1 ; Input
+2 ; TYPE = Measurement choice (APCDTTYP)
+3 ; X = value of the measurement (APCDTVAL)
+4 ;
+5 NEW BQIXTYP,TTYPE,EXEC
+6 SET TTYPE=TYPE
+7 ;I TYPE?.N S TTYPE=$P(^AUTTMSR(TYPE,0),U,1)
+8 ;S BQIXTYP=TTYPE_"^AUPNVMSR"
+9 SET EXEC=$GET(^AUTTMSR(TYPE,12))
+10 IF EXEC'=""
XECUTE EXEC
+11 ;D @BQIXTYP
+12 IF $GET(X)=""
SET RESULT=-1
QUIT
+13 SET RESULT=1
+14 QUIT
+15 ;
SKT(RESLT,READ) ;EP - Skin Test
+1 ; Input
+2 ; RESLT - Result (APCDTRES)
+3 ; READ - Reading (APCDTREA)
+4 ; Output
+5 ; RESULT=-1 didn't pass validation
+6 ; RESULT=1 passed validation
+7 ;
+8 ; Only check validation if both values are populated
+9 IF $GET(RESLT)=""!($GET(READ)="")
SET RESULT=1
QUIT
+10 ;
+11 ; If result is 'Negative' and result is greater than 10
+12 IF $GET(RESLT)="N"&($GET(READ)>10)
SET RESULT=-1
QUIT
+13 ;
+14 IF $GET(RESLT)'="P"&($GET(READ)>10)
SET RESULT=-1
QUIT
+15 ;
+16 SET RESULT=1
+17 QUIT
+18 ;
EXM(EXAM,RESLT) ;EP - Exam result
+1 ; Input
+2 ; EXAM - Exam Type
+3 ; RESLT - The entered result
+4 ;
+5 IF EXAM'?.N
SET EXAM=$$FIND1^DIC(9999999.15,"","B",EXAM,"","","ERROR")
+6 NEW C
+7 SET C=$PIECE(^AUTTEXAM(EXAM,0),U,2)
+8 IF RESLT="PA"
IF C'=34
SET RESULT=-1
QUIT
+9 IF RESLT="PR"
IF C'=34
SET RESULT=-1
QUIT
+10 IF RESLT="A"
IF C=34
SET RESULT=-1
QUIT
+11 IF RESLT="A"
IF C=35
SET RESULT=-1
QUIT
+12 IF RESLT="A"
IF C=36
SET RESULT=-1
QUIT
+13 IF RESLT="PO"
IF (C'=35&(C'=36))
SET RESULT=-1
QUIT
+14 SET RESULT=1
+15 QUIT
+16 ;
LAB(TEST,RESLT) ;EP - Lab Result
+1 ; Input
+2 ; TEST - Lab Test IEN
+3 ; RESLT - The entered result
+4 ;
+5 ; Take out validation for a lab result for historical entry
+6 ; Allow them to enter anything they please
+7 SET RESULT=1
+8 QUIT
+9 NEW WHERE,LDATA,X
+10 SET WHERE=$PIECE(^LAB(60,TEST,0),U,12)
+11 IF WHERE=""
SET RESULT=1
QUIT
+12 SET LDATA=U_WHERE_"0)"
+13 SET EXEC=$PIECE(@LDATA,U,5,99)
+14 SET X=RESLT
XECUTE EXEC
+15 IF $GET(X)=""
SET RESULT=-1
QUIT
+16 SET RESULT=1
+17 QUIT
+18 ;
LOC(LOC) ; EP - Location
+1 ; Input
+2 ; Location IEN
+3 SET RESULT=1
+4 IF $EXTRACT($$GET1^DIQ(4,LOC_",",.01,"E"),1,5)="OTHER"
Begin DoDot:1
+5 IF $PIECE($GET(^APCDSITE(DUZ(2),0)),U,16)'="Y"
SET RESULT=-1
SET MSG="Your site parameters file does not indicate outside location can be entered!"
QUIT
End DoDot:1
+6 QUIT
+7 ;
VDT(VDAT,DFN) ; EP - Visit Date
+1 ; Input
+2 ; VDAT - Visit date from APCDDATE
+3 ; DFN - Patient IEN
+4 SET RESULT=1
+5 SET DOB=$$GET1^DIQ(2,DFN_",",.03,"I")
+6 SET DOD=$$GET1^DIQ(2,DFN_",",.351,"I")
+7 SET VDAT=$$DATE^BQIUL1(VDAT)
+8 ;
+9 IF VDAT\1>DT
SET RESULT=-1
SET MSG="Future dates not valid"
QUIT
+10 IF VDAT\1<DOB
SET RESULT=-1
SET MSG="Date cannot be before Date of Birth ("_$$FMTE^BQIUL1(DOB)_")"
QUIT
+11 IF DOD'=""
Begin DoDot:1
+12 IF VDAT\1>DOD
SET RESULT=-1
SET MSG="Date cannot be after Date of Death ("_$$FMTE^BQIUL1(DOD)_")"
QUIT
End DoDot:1
+13 QUIT
+14 ;
PDT(PDAT,VDAT,DFN) ; EP - Procedure Date
+1 ; Input
+2 ; PDAT - Procedure date
+3 ; VDAT - Visit date from APCDDATE
+4 ; DFN - Patient IEN
+5 SET RESULT=1
+6 SET DOB=$$GET1^DIQ(2,DFN_",",.03,"I")
+7 SET DOD=$$GET1^DIQ(2,DFN_",",.351,"I")
+8 SET VDAT=$$DATE^BQIUL1(VDAT)
+9 SET PDAT=$$DATE^BQIUL1(PDAT)
+10 ;
+11 IF PDAT<(VDAT\1)
SET RESULT=-1
SET MSG="Procedure date cannot be before Visit date"
QUIT
+12 IF PDAT\1>DT
SET RESULT=-1
SET MSG="Future dates not valid"
QUIT
+13 IF PDAT\1<DOB
SET RESULT=-1
SET MSG="Date cannot be before Date of Birth ("_$$FMTE^BQIUL1(DOB)_")"
QUIT
+14 IF DOD'=""
Begin DoDot:1
+15 IF PDAT\1>DOD
SET RESULT=-1
SET MSG="Date cannot be after Date of Death ("_$$FMTE^BQIUL1(DOD)_")"
QUIT
End DoDot:1
+16 QUIT
+17 ;
EPRV(APCDTPRO) ; EP - Education Provider
+1 SET RESULT=1
+2 IF $PIECE($GET(^VA(200,APCDTPRO,"PS")),U,4)'=""
SET RESULT=-1
SET MSG="The provider you selected is not an authorized provider for Patient Education entries."
+3 QUIT
+4 ;
HIVDT(DFN,BKMDXDT,BKMAIDT) ; EP - Initial HIV DX Date
+1 NEW X,AIDSDT,DOB,BKMIEN,BKMREG,BKMIENS,DA
+2 SET RESULT=1
+3 IF BKMDXDT=""
IF BKMAIDT=""
QUIT
+4 SET BKMIEN=$$BKMIEN^BKMIXX3(DFN)
+5 SET BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
+6 SET DA(1)=BKMIEN
SET DA=BKMREG
+7 SET BKMIENS=$$IENS^DILF(.DA)
+8 SET AIDSDT=$$DATE^BQIUL1($GET(BKMAIDT))
+9 ; $$GET1^DIQ(90451.01,BKMIENS,5.5,"I"))
+10 SET DOB=$$GET1^DIQ(2,DFN,.03,"I")
+11 SET X=$$DATE^BQIUL1(BKMDXDT)
+12 IF DOB>X
SET RESULT=-1
SET MSG="Date cannot be before Date of Birth ("_$$FMTE^BQIUL1(DOB)_")"
QUIT
+13 IF X>DT
SET RESULT=-1
SET MSG="Future dates not valid"
QUIT
+14 IF AIDSDT'=""
IF X>AIDSDT
SET RESULT=-1
SET MSG="Initial HIV DX Date cannot be later than Initial AIDS DX Date"
QUIT
+15 QUIT
+16 ;
AIDDT(DFN,BKMAIDT,BKMDXDT) ; EP - Initial AIDS DX Date
+1 NEW X,HIVDT,DOB,BKMIEN,BKMREG,BKMIENS,DA
+2 SET RESULT=1
+3 IF BKMAIDT=""
IF BKMDXDT=""
QUIT
+4 SET BKMIEN=$$BKMIEN^BKMIXX3(DFN)
+5 SET BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
+6 SET DA(1)=BKMIEN
SET DA=BKMREG
+7 SET BKMIENS=$$IENS^DILF(.DA)
+8 SET HIVDT=$$DATE^BQIUL1($GET(BKMDXDT))
+9 ;$$GET1^DIQ(90451.01,BKMIENS,5,"I")
+10 SET DOB=$$GET1^DIQ(2,DFN,.03,"I")
+11 SET X=$$DATE^BQIUL1(BKMAIDT)
+12 IF DOB>X
SET RESULT=-1
SET MSG="Date cannot be before Date of Birth ("_$$FMTE^BQIUL1(DOB)_")"
QUIT
+13 IF X>DT
SET RESULT=-1
SET MSG="Future dates not valid"
QUIT
+14 IF HIVDT'=""
IF X<HIVDT
SET RESULT=-1
SET MSG="Initial AIDS DX Date cannot be before the Initial HIV DX Date"
+15 QUIT
+16 ;
RDT(SKRDT) ; EP - Skin Test Reading Date
+1 SET SKRDT=$$DATE^BQIUL1($GET(SKRDT))
+2 IF SKRDT\1>DT
SET RESULT=-1
SET MSG="Future dates not valid"
QUIT
+3 SET RESULT=1
+4 QUIT
+5 ;
BDT(VDAT,DFN) ; EP - Problem Date of Onset
+1 ; Input
+2 ; VDAT - Visit date from APCDDATE
+3 ; DFN - Patient IEN
+4 SET RESULT=1
+5 IF VDAT=""
QUIT
+6 SET DOB=$$GET1^DIQ(2,DFN_",",.03,"I")
+7 SET DOD=$$GET1^DIQ(2,DFN_",",.351,"I")
+8 SET VDAT=$$DATE^BQIUL1(VDAT)
+9 ;
+10 IF VDAT\1>DT
SET RESULT=-1
SET MSG="Future dates not valid"
QUIT
+11 IF VDAT\1<DOB
SET RESULT=-1
SET MSG="Date cannot be before Date of Birth ("_$$FMTE^BQIUL1(DOB)_")"
QUIT
+12 IF DOD'=""
Begin DoDot:1
+13 IF VDAT\1>DOD
SET RESULT=-1
SET MSG="Date cannot be after Date of Death ("_$$FMTE^BQIUL1(DOD)_")"
QUIT
End DoDot:1
+14 QUIT
+15 ;
CLAS(DX,CLS) ; EP - Classification validation
+1 IF $$VERSION^XPDUTL("BJPC")<2.0
SET RESULT=1
QUIT
+2 NEW X,BQA,TX,LW,HG
+3 IF CLS=""
SET RESULT=1
QUIT
+4 SET X=CLS
+5 SET BQA=0
FOR
SET BQA=$ORDER(^APCDPLCL(BQA))
IF BQA'=+BQA!('$DATA(X))
QUIT
Begin DoDot:1
+6 SET TX=$PIECE(^APCDPLCL(BQA,0),U,2)
+7 IF TX=""
QUIT
+8 IF '$DATA(^ATXAX(TX))
QUIT
+9 ;not in this taxonomy
IF '$$ICD^ATXCHK(DX,TX,9)
QUIT
+10 SET LW=$PIECE(^APCDPLCL(BQA,0),U,3)
+11 SET HG=$PIECE(^APCDPLCL(BQA,0),U,4)
+12 IF X<LW!(X>HG)
KILL X
+13 QUIT
End DoDot:1
+14 IF $GET(X)=""
SET RESULT=-1
SET MSG="Invalid selection"
QUIT
+15 SET RESULT=1
+16 QUIT
+17 ;
TXNM(AMQQTNAR) ; EP - Taxonomy name validation
+1 NEW AMQN
+2 SET RESULT=1
+3 IF AMQQTNAR=""
SET RESULT=-1
SET MSG="No name provided"
QUIT
+4 IF $DATA(^ATXAX("B",AMQQTNAR))>0
Begin DoDot:1
+5 SET AMQN=$ORDER(^ATXAX("B",AMQQTNAR,""))
+6 IF DUZ'=$PIECE(^ATXAX(AMQN,0),U,5)
SET RESULT=-1
SET MSG="Name already exists and cannot be overwritten except by its creator."
QUIT
+7 SET RESULT=-1
SET MSG="Replace existing taxonomy with this one?"
SET HNDLR="O"
QUIT
End DoDot:1
QUIT
+8 QUIT
+9 ;
CPT(VDAT,NCPT) ; EP - CPT Code validation
+1 SET RESULT=1
+2 SET VDAT=$$DATE^BQIUL1(VDAT)
+3 IF NCPT=""
SET RESULT=-1
SET MSG="No CPT code provided"
QUIT
+4 IF $PIECE($$CPT^ICPTCOD(NCPT,VDAT),U,7)=0
SET RESULT=-1
SET MSG="CPT Code not valid for this visit date"
QUIT
+5 QUIT
+6 ;
IMP(VALUE) ; EP - Imprecise date validation
+1 SET RESULT=1
+2 SET VALUE=$$DATE^BQIUL1(VALUE)
+3 IF VALUE=""
SET RESULT=-1
SET MSG="Invalid date"
QUIT
+4 QUIT
