- DGRPC ;ALB/MRL,PJR,PHH,EG,BAJ,TDM,LBD,RN,ARF,JDB,JDB - CHECK CONSISTENCY OF PATIENT DATA ;6/29/11 3:50pm
- ;;5.3;Registration;**108,121,314,301,470,489,505,451,568,585,641,653,688,754,797,867,903,952,1027,1045,1081,1098,1111**;Aug 13, 1993;Build 18
- ;Per VHA Directive 6402, this routine should not be modified.
- ;
- ; 315 added to OVER99 local variable by patch DG*5.3*903 which was submitted to OSEHRA
- ; on 04/02/2015 by HP. This update was authored by James Harris 2014-2015
- ;
- ;line tags in routines correspond to IEN of file 38.6
- ;
- ;variables: DGVT = 1 if VETERAN? = YES, 0 if NO
- ; DGSC = 1 if SC? = YES, 0 if NO
- ; DGCD = 0 node of file EC file (#8)
- ; DGRPCOLD = old inconsistencies for pt (separated by ,s)
- ; DGCHK = #s to check (separated by ,s)
- ; DGLST = next # to check
- ; DGER = inconsistencies found (separated by ,s)
- ; DGNCK = 1 if missing key elig data...can't process further
- ;
- N ANYMSE,CONARR,CONCHK,CONERR,CONSPEC,LOC,I5,I6,DGPMSE
- N MSECHK,MSESET,MSERR,MSDATERR,RANGE,RANSET,OVER99
- D ON I $S(('$D(DFN)#2):1,'$D(^DPT(DFN,0)):1,DGER:1,1:0) G KVAR^DGRPCE:DGER
- EN ; DG*5.3*1027 Screen 7 changes - call new consistency check
- D VETINDCHG
- S:'$D(DGEDCN)#2 DGEDCN=0 I DGEDCN W !!,"Checking data for consistency..."
- D START:DGEDCN
- F I=0,.13,.141,.121,.122,.22,.24,.3,.31,.311,.32,.321,.322,.33,.35,.36,.362,.38,.39,.52,.53,"TYPE","VET" S DGP(I)=$G(^DPT(DFN,I))
- ;Get MSEs from MSE sub-file #2.3216 (DG*5.3*797)
- I '$D(^DPT(DFN,.3216)) D MOVMSE^DGMSEUTL(DFN)
- D GETMSE^DGMSEUTL(DFN,.DGPMSE)
- ;get old inconsistencies
- S DGRPCOLD="," I $D(^DGIN(38.5,DFN)) F I=0:0 S I=$O(^DGIN(38.5,DFN,"I",I)) Q:'I S DGRPCOLD=DGRPCOLD_I_","
- ;find consistencies to check/not check
- ; DG*5.3*653 modified to exclude checks numbered>99 BAJ 10/25/2005
- ; DG*5.3*1081 modified to exclude 15, INEL REASON UNSPECIFIED, ineligibility consistency check
- ;S DGCHK="," F I=0:0 S I=$O(^DGIN(38.6,I)) Q:'I!(I=99) I $D(^(I,0)),$S(I=2:0,I=51:0,I=9:1,I=10:1,I=13:1,I=14:1,I=22:1,I=52:1,I=53:1,I=89:1,'$P(^(0),"^",5):1,1:0),I'=99 S DGCHK=DGCHK_I_","
- ; DG*5.3*1111 modified to remove "always true" conditions for 52, INSURANCE PROMPT UNANSWERED and 53, EMPLOYMENT STATUS UNANSWERED which will both now obey CHECK/DON'T CHECK, Field (#5)
- ;S DGCHK="," F I=0:0 S I=$O(^DGIN(38.6,I)) Q:'I!(I=99) I $D(^(I,0)),$S(I=2:0,I=51:0,I=9:1,I=10:1,I=13:1,I=14:1,I=22:1,I=52:1,I=53:1,I=89:1,'$P(^(0),"^",5):1,1:0),I'=99,I'=15 S DGCHK=DGCHK_I_","
- S DGCHK="," F I=0:0 S I=$O(^DGIN(38.6,I)) Q:'I!(I=99) I $D(^(I,0)),$S(I=2:0,I=51:0,I=9:1,I=10:1,I=13:1,I=14:1,I=22:1,I=89:1,'$P(^(0),"^",5):1,1:0),I'=99,I'=15 S DGCHK=DGCHK_I_","
- ; DG*5.3*1098 removed 406: CLAIM FOLDER NUMBER INVALID from consistency check OVER99 variable string since the rule was removed from INCONSISTENT DATA ELEMENT File (#38.6).
- S OVER99=",301,303,304,306,307,308,313,314,315,402,403,407,501,502,503,504,505,506,507,516,517,"
- S DGVT=$S(DGP("VET")="Y":1,1:0),DGSC=$S($P(DGP(.3),"^",1)="Y":1,1:0),DGCD=$S($D(^DIC(8,+DGP(.36),0)):^(0),1:""),(DGCT,DGER,DGNCK)="" I 'DGVT,$D(^DG(391,+DGP("TYPE"),0)),$P(^(0),"^",2) S DGVT=2
- S DGLST=+$P(DGCHK,",",2) G @DGLST
- 1 S DGD=$P(DGP(0),"^",1) I DGD?1L.E!(DGD?.E1L.E)!(DGD="") S X=1 D COMB,NEXT I +DGLST'=2 G @DGLST
- S I1=0 F I=1:1:$L(DGD) Q:I1 S J=$E(DGD,I) I J?1NP,$A(J)>32,J'=",",J'="-",J'=".",J'="'" S I1=1
- I I1 S X=1 D COMB
- D NEXT I +DGLST'=2 G @DGLST
- 2 S I1=0 F I=0:0 S I=$O(^DPT(DFN,.01,I)) Q:'I!(I1) I $P(^(I,0),"^",1)'?1A.E S I1=1
- I I1 S X=2 D COMB
- D NEXT I +DGLST>7!('DGLST) G @DGLST
- 3 ;
- 4 ;
- 5 ;
- 6 ;
- 7 F I=2,3,5,8,9 I $P(DGP(0),"^",I)="" S X=$S(I=2:3,I=3:4,I=5:5,I=8:6,1:7) D COMB:DGCHK[(","_X_",")
- S DGLST=7 G:DGCHK'[",7," FIND^DGRPC2 D NEXT I +DGLST'=8 G @DGLST
- 8 S I1=0,DGD=$G(^DPT(DFN,.11)) I '$P(DGD,"^",10) S I1=1,X=8 D COMB,NEXT G @DGLST
- I '$D(^HL(779.004,$P(DGD,"^",10))) S I1=1,X=8 D COMB,NEXT G @DGLST
- N STR8 S STR8="1,4,5,6,7" I $$FORIEN^DGADDUTL($P(DGD,"^",10)) S STR8="1,4"
- F T=1:1:$L(STR8,",") S I=$P(STR8,",",T) Q:I1 I $P(DGD,"^",I)="" S I1=1
- I I1 S X=8 D COMB
- D NEXT I +DGLST'=9 G @DGLST
- 9 I DGP("VET")="" S X=9,DGNCK=1 D COMB
- D NEXT I +DGLST'=10 G @DGLST
- 10 I $P(DGP(.3),"^",1)="" S X=10,DGNCK=1 D COMB
- D NEXT I +DGLST'=11 G @DGLST
- 11 I 'DGVT,DGSC S X=11 D COMB
- D NEXT I +DGLST'=12 G @DGLST
- 12 I DGSC,DGVT,$P(DGP(.3),"^",2)="" S X=12 D COMB
- D NEXT I +DGLST'=13 G @DGLST
- 13 I '$D(^DIC(21,+$P(DGP(.32),"^",3),0)) S X=13,DGNCK=1 D COMB
- D NEXT I +DGLST'=14 G @DGLST
- 14 I $P(DGCD,"^",1)="" S X=14,DGNCK=1 D COMB
- ;
- ;Check Patient Eligibilities multiple if Primary Elig Code defined
- I DGP(.36),'$D(^DPT(DFN,"E",+DGP(.36),0)) D PRI^VADPT60 ;5.3*301
- ;
- D NEXT I +DGLST'=15 G FIND^DGRPC2:+DGLST=35,@DGLST
- 15 I $P($G(^DPT(DFN,.15)),"^",2)]"",$P(DGP(.3),"^",7)="" S X=15 D COMB
- D NEXT I +DGLST'=16 G FIND^DGRPC2:+DGLST=35,@DGLST
- 16 D H^DGUTL I +DGP(.35)>DGTIME S X=16 D COMB
- D NEXT I +DGLST'=17 G FIND^DGRPC2:+DGLST=35,@DGLST
- 17 K DGDATE,DGTIME
- N SDARRAY,SDCLIEN,SDDATE
- S I1=0,DGD=DT
- S SDARRAY("FLDS")=3
- S SDARRAY(4)=DFN
- I +DGP(.35),$$SDAPI^SDAMA301(.SDARRAY) D
- .;if there is data hanging from the 101 subscript,
- .;then this is a valid appointment
- .;otherwise it is an error eg 01/21/2005
- .I $D(^TMP($J,"SDAMA301",101))=1 Q
- .S SDCLIEN=0
- .F S SDCLIEN=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN)) Q:'SDCLIEN!(I1) D
- ..S SDDATE=0
- ..F S SDDATE=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE)) Q:'SDDATE!(I1) D
- ...S X=$P($P(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE),"^",3),";")
- ...I X=""!(X="I") S I1=1
- K ^TMP($J,"SDAMA301")
- I I1 S X=17 D COMB
- ;
- END ; end of routine...find next check to execute (or goto end)
- S:DGNCK DGLST=35 G:DGCHK'[",35,"&(DGNCK) FIND^DGRPC2 D NEXT G @DGLST
- ;
- COMB ;record inconsistency
- S DGCT=DGCT+1,DGER=DGER_X_",",DGLST=X Q
- Q
- ;
- NEXT ; find the next consistency check to check (goto end if can't process further)
- S I=$F(DGCHK,(","_DGLST_",")),DGLST=+$E(DGCHK,I,999) I +DGLST,DGLST<18 Q
- I +DGLST,DGNCK,+DGLST>17,+DGLST<36 S DGLST=35 Q:DGCHK'[",35," G NEXT
- S:'+DGLST DGLST="END^DGRPC3" I +DGLST S DGLST=DGLST_"^DGRPC"_$S(+DGLST<43:1,+DGLST<79:2,1:3)
- Q
- ;
- PAT ;check inconsistencies for a selected patient
- D ON G KVAR^DGRPCE:DGER W !! S DIC="^DPT(",DIC(0)="AEQMZ",DIC("A")="Check consistency for which PATIENT: " D ^DIC K DIC G KVAR^DGRPCE:Y'>0 S DFN=+Y,DGEDCN=1 D DGRPC G PAT
- ;
- START ;record start time for checker
- S DGSTART=$H Q
- ;
- TIME ;record end time for checker
- Q:'$D(DGSTART)#2 S DGEND=$H,X=$P(DGSTART,",",2),X1=$P(DGEND,",",2)
- I +DGSTART=+DGEND S DGTIME=X1-X
- E S DGTIME=(5184000-X)+X1
- I $S(DGCT:0,DGCON=1:1,1:0) G TIMEQ
- W !!,"===> ",$S(DGCT:DGCT,DGCON<2:"No",1:"All")," inconsistenc",$S(DGCT=1:"y",1:"ies")," ",$S('DGCON:"found",DGCON=1:"filed",1:"removed")," in ",DGTIME," second",$S(DGTIME=1:"",1:"s"),"..." H 1
- TIMEQ K DGSTART,DGEND,DGTIME,X,X1,DGCON Q
- ;
- ON ;check if checker is on
- S DGER=0 I $S('$D(^DG(43,1,0)):1,'$P(^(0),"^",37):1,1:0) S DGER=1
- S:'$D(DGEDCN) DGEDCN=0 W:DGER !!,"CONSISTENCY CHECKER TURNED OFF!!",$C(7) Q
- VETINDCHG ; DG*5.3*1027 Vet indicator change
- ; If DO YOU WISH TO ENROLL field in PATIENT (#2) file is YES AND
- ; A record for the patient does not exist in the Patient Enrollment file AND
- ; The patient is unknown to ES Then Incomplete Enrollment.
- ; Supported DBIA #2701: The supported DBIA is used to access MPI
- ; APIs to retrieve ICN, determine if ICN
- ; is local and if site is LST.
- ; Supported ICRs
- ; #3356 - XQY0 ; Kernel Variable
- ;
- ; Quit if not in specific menu options or if there is a current enrollment
- I ($P($G(XQY0),"^",1)'="DG REGISTER PATIENT"),($P($G(XQY0),"^",1)'="DG LOAD PATIENT DATA"),($P($G(XQY0),"^",1)'="DG ELIGIBILITY VERIFICATION"),($P($G(XQY0),"^",1)'="DGPRE PRE-REGISTER OPTION") QUIT
- I $$FINDCUR^DGENA(DFN) QUIT
- N DGKEY,DGREQNAME,DGENSTAT,DGWSHTOEN,DGRESP,DGVET,DGOVET,DTOUT,DUOUT
- S DGREQNAME="VistAData"
- S DGRESP=0
- S DGKEY=$$GETICN^MPIF001(DFN),DGVET=$$VET^DGENPTA(DFN),DGOVET=$G(^TMP($J,"DGOLDVET",DFN))
- I $P(DGKEY,"^",1)'=-1 S DGRESP=$$EN^DGREGEEWS(DGKEY,DGREQNAME,.DGENSTAT,.DGWSHTOEN)
- I +DGRESP=0,'$G(DGDONE),$P($G(XQY0),"^",1)'="DG REGISTER PATIENT" D
- . W !!,"This patient has not had the Enrollment Request Process completed and this must be done through Register A Patient."
- . S DGDONE=1
- . N DIR,X,Y
- . S DIR(0)="E"
- . D ^DIR K DIR
- I DGOVET'="",$P($G(XQY0),"^",1)="DG REGISTER PATIENT",+DGRESP=0,DGVET'=DGOVET,'$G(DGDONE2) D
- . I DGVET=1 D
- . . W !,"Veteran indicator has been changed. ""Do You Wish To Enroll"" is currently set to NO."
- . . W !!,"Use the Enrollment System if the Veteran wishes to enroll."
- . . N DIR,X,Y
- . . S DIR(0)="E"
- . . D ^DIR
- . I DGVET=0 D
- . . N DGINELIG,DGENPTA
- . . I $$GET^DGENPTA(DFN,.DGENPTA) S DGINELIG=$G(DGENPTA("INELDATE"))
- . . I ($G(DGENRYN)=1),DGINELIG="" D REGORSN ;self-reported reason prompt
- . . I DGINELIG="" D APPTCHG ; DG*5.3*1045 - If there is no Ineligible Date, set the Appointment request fields to null
- . S DGDONE2=1
- Q
- APPTCHG ; DG*5.3*1027 Vet indicator change from Yes to No
- ;Remove the Appointment Request information
- N DGIENS,DGRSLT,DGFDA
- S DGRSLT=""
- S DGIENS=DFN_","
- ;APPOINTMENT REQUEST ON 1010EZ 1010.15;9
- S DGFDA(2,DGIENS,1010.159)=DGRSLT ;
- ;APPOINTMENT REQUEST DATE 1010.15;11
- S DGFDA(2,DGIENS,1010.1511)=DGRSLT
- ;ORIGINAL APPOINTMENT REQUEST 1010.15;12
- S DGFDA(2,DGIENS,1010.1512)=DGRSLT
- ;ORIGINAL APPT REQUEST DATE 1010.15;13
- S DGFDA(2,DGIENS,1010.1513)=DGRSLT
- ;ORIG APPT REQUEST CHG DT/TM 1010.15;14
- S DGFDA(2,DGIENS,1010.1514)=DGRSLT
- ;APPT REQUEST 1010EZ CHG DT/TM 1010.15;15
- S DGFDA(2,DGIENS,1010.1515)=DGRSLT
- D FILE^DIE("","DGFDA")
- Q
- REGORSN ; DG*5.3*1027 Display prompt for REGISTRATION ONLY REASON
- N DGNOW,DGENRODT,DGENSRCE,DGENRRSN,DIR,X,Y,DUOUT,DTOUT
- F D Q:DGENRRSN
- . K DIR
- . S DIR("A")="SELF-REPORTED REGISTRATION ONLY REASON: "
- . S DIR(0)="27.11,.15,AO"
- . D ^DIR Q:$D(DTOUT)!($D(DUOUT))
- . S DGENRRSN=+Y
- . I 'DGENRRSN W !,"This is a required field.",!
- I DGENRRSN S DGNOW=$$NOW^XLFDT(),DGENRODT=DGNOW,DGENSRCE=1 D REGONLY^DGEN(DFN)
- S DGENRYN=0
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPC 10348 printed Jan 18, 2025@03:56:33 Page 2
- DGRPC ;ALB/MRL,PJR,PHH,EG,BAJ,TDM,LBD,RN,ARF,JDB,JDB - CHECK CONSISTENCY OF PATIENT DATA ;6/29/11 3:50pm
- +1 ;;5.3;Registration;**108,121,314,301,470,489,505,451,568,585,641,653,688,754,797,867,903,952,1027,1045,1081,1098,1111**;Aug 13, 1993;Build 18
- +2 ;Per VHA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ; 315 added to OVER99 local variable by patch DG*5.3*903 which was submitted to OSEHRA
- +5 ; on 04/02/2015 by HP. This update was authored by James Harris 2014-2015
- +6 ;
- +7 ;line tags in routines correspond to IEN of file 38.6
- +8 ;
- +9 ;variables: DGVT = 1 if VETERAN? = YES, 0 if NO
- +10 ; DGSC = 1 if SC? = YES, 0 if NO
- +11 ; DGCD = 0 node of file EC file (#8)
- +12 ; DGRPCOLD = old inconsistencies for pt (separated by ,s)
- +13 ; DGCHK = #s to check (separated by ,s)
- +14 ; DGLST = next # to check
- +15 ; DGER = inconsistencies found (separated by ,s)
- +16 ; DGNCK = 1 if missing key elig data...can't process further
- +17 ;
- +18 NEW ANYMSE,CONARR,CONCHK,CONERR,CONSPEC,LOC,I5,I6,DGPMSE
- +19 NEW MSECHK,MSESET,MSERR,MSDATERR,RANGE,RANSET,OVER99
- +20 DO ON
- IF $SELECT(('$DATA(DFN)#2):1,'$DATA(^DPT(DFN,0)):1,DGER:1,1:0)
- if DGER
- GOTO KVAR^DGRPCE
- EN ; DG*5.3*1027 Screen 7 changes - call new consistency check
- +1 DO VETINDCHG
- +2 if '$DATA(DGEDCN)#2
- SET DGEDCN=0
- IF DGEDCN
- WRITE !!,"Checking data for consistency..."
- +3 if DGEDCN
- DO START
- +4 FOR I=0,.13,.141,.121,.122,.22,.24,.3,.31,.311,.32,.321,.322,.33,.35,.36,.362,.38,.39,.52,.53,"TYPE","VET"
- SET DGP(I)=$GET(^DPT(DFN,I))
- +5 ;Get MSEs from MSE sub-file #2.3216 (DG*5.3*797)
- +6 IF '$DATA(^DPT(DFN,.3216))
- DO MOVMSE^DGMSEUTL(DFN)
- +7 DO GETMSE^DGMSEUTL(DFN,.DGPMSE)
- +8 ;get old inconsistencies
- +9 SET DGRPCOLD=","
- IF $DATA(^DGIN(38.5,DFN))
- FOR I=0:0
- SET I=$ORDER(^DGIN(38.5,DFN,"I",I))
- if 'I
- QUIT
- SET DGRPCOLD=DGRPCOLD_I_","
- +10 ;find consistencies to check/not check
- +11 ; DG*5.3*653 modified to exclude checks numbered>99 BAJ 10/25/2005
- +12 ; DG*5.3*1081 modified to exclude 15, INEL REASON UNSPECIFIED, ineligibility consistency check
- +13 ;S DGCHK="," F I=0:0 S I=$O(^DGIN(38.6,I)) Q:'I!(I=99) I $D(^(I,0)),$S(I=2:0,I=51:0,I=9:1,I=10:1,I=13:1,I=14:1,I=22:1,I=52:1,I=53:1,I=89:1,'$P(^(0),"^",5):1,1:0),I'=99 S DGCHK=DGCHK_I_","
- +14 ; DG*5.3*1111 modified to remove "always true" conditions for 52, INSURANCE PROMPT UNANSWERED and 53, EMPLOYMENT STATUS UNANSWERED which will both now obey CHECK/DON'T CHECK, Field (#5)
- +15 ;S DGCHK="," F I=0:0 S I=$O(^DGIN(38.6,I)) Q:'I!(I=99) I $D(^(I,0)),$S(I=2:0,I=51:0,I=9:1,I=10:1,I=13:1,I=14:1,I=22:1,I=52:1,I=53:1,I=89:1,'$P(^(0),"^",5):1,1:0),I'=99,I'=15 S DGCHK=DGCHK_I_","
- +16 SET DGCHK=","
- FOR I=0:0
- SET I=$ORDER(^DGIN(38.6,I))
- if 'I!(I=99)
- QUIT
- IF $DATA(^(I,0))
- IF $SELECT(I=2:0,I=51:0,I=9:1,I=10:1,I=13:1,I=14:1,I=22:1,I=89:1,'$PIECE(^(0),"^",5):1,1:0)
- IF I'=99
- IF I'=15
- SET DGCHK=DGCHK_I_","
- +17 ; DG*5.3*1098 removed 406: CLAIM FOLDER NUMBER INVALID from consistency check OVER99 variable string since the rule was removed from INCONSISTENT DATA ELEMENT File (#38.6).
- +18 SET OVER99=",301,303,304,306,307,308,313,314,315,402,403,407,501,502,503,504,505,506,507,516,517,"
- +19 SET DGVT=$SELECT(DGP("VET")="Y":1,1:0)
- SET DGSC=$SELECT($PIECE(DGP(.3),"^",1)="Y":1,1:0)
- SET DGCD=$SELECT($DATA(^DIC(8,+DGP(.36),0)):^(0),1:"")
- SET (DGCT,DGER,DGNCK)=""
- IF 'DGVT
- IF $DATA(^DG(391,+DGP("TYPE"),0))
- IF $PIECE(^(0),"^",2)
- SET DGVT=2
- +20 SET DGLST=+$PIECE(DGCHK,",",2)
- GOTO @DGLST
- 1 SET DGD=$PIECE(DGP(0),"^",1)
- IF DGD?1L.E!(DGD?.E1L.E)!(DGD="")
- SET X=1
- DO COMB
- DO NEXT
- IF +DGLST'=2
- GOTO @DGLST
- +1 SET I1=0
- FOR I=1:1:$LENGTH(DGD)
- if I1
- QUIT
- SET J=$EXTRACT(DGD,I)
- IF J?1NP
- IF $ASCII(J)>32
- IF J'=","
- IF J'="-"
- IF J'="."
- IF J'="'"
- SET I1=1
- +2 IF I1
- SET X=1
- DO COMB
- +3 DO NEXT
- IF +DGLST'=2
- GOTO @DGLST
- 2 SET I1=0
- FOR I=0:0
- SET I=$ORDER(^DPT(DFN,.01,I))
- if 'I!(I1)
- QUIT
- IF $PIECE(^(I,0),"^",1)'?1A.E
- SET I1=1
- +1 IF I1
- SET X=2
- DO COMB
- +2 DO NEXT
- IF +DGLST>7!('DGLST)
- GOTO @DGLST
- 3 ;
- 4 ;
- 5 ;
- 6 ;
- 7 FOR I=2,3,5,8,9
- IF $PIECE(DGP(0),"^",I)=""
- SET X=$SELECT(I=2:3,I=3:4,I=5:5,I=8:6,1:7)
- if DGCHK[(","_X_",")
- DO COMB
- +1 SET DGLST=7
- if DGCHK'[",7,"
- GOTO FIND^DGRPC2
- DO NEXT
- IF +DGLST'=8
- GOTO @DGLST
- 8 SET I1=0
- SET DGD=$GET(^DPT(DFN,.11))
- IF '$PIECE(DGD,"^",10)
- SET I1=1
- SET X=8
- DO COMB
- DO NEXT
- GOTO @DGLST
- +1 IF '$DATA(^HL(779.004,$PIECE(DGD,"^",10)))
- SET I1=1
- SET X=8
- DO COMB
- DO NEXT
- GOTO @DGLST
- +2 NEW STR8
- SET STR8="1,4,5,6,7"
- IF $$FORIEN^DGADDUTL($PIECE(DGD,"^",10))
- SET STR8="1,4"
- +3 FOR T=1:1:$LENGTH(STR8,",")
- SET I=$PIECE(STR8,",",T)
- if I1
- QUIT
- IF $PIECE(DGD,"^",I)=""
- SET I1=1
- +4 IF I1
- SET X=8
- DO COMB
- +5 DO NEXT
- IF +DGLST'=9
- GOTO @DGLST
- 9 IF DGP("VET")=""
- SET X=9
- SET DGNCK=1
- DO COMB
- +1 DO NEXT
- IF +DGLST'=10
- GOTO @DGLST
- 10 IF $PIECE(DGP(.3),"^",1)=""
- SET X=10
- SET DGNCK=1
- DO COMB
- +1 DO NEXT
- IF +DGLST'=11
- GOTO @DGLST
- 11 IF 'DGVT
- IF DGSC
- SET X=11
- DO COMB
- +1 DO NEXT
- IF +DGLST'=12
- GOTO @DGLST
- 12 IF DGSC
- IF DGVT
- IF $PIECE(DGP(.3),"^",2)=""
- SET X=12
- DO COMB
- +1 DO NEXT
- IF +DGLST'=13
- GOTO @DGLST
- 13 IF '$DATA(^DIC(21,+$PIECE(DGP(.32),"^",3),0))
- SET X=13
- SET DGNCK=1
- DO COMB
- +1 DO NEXT
- IF +DGLST'=14
- GOTO @DGLST
- 14 IF $PIECE(DGCD,"^",1)=""
- SET X=14
- SET DGNCK=1
- DO COMB
- +1 ;
- +2 ;Check Patient Eligibilities multiple if Primary Elig Code defined
- +3 ;5.3*301
- IF DGP(.36)
- IF '$DATA(^DPT(DFN,"E",+DGP(.36),0))
- DO PRI^VADPT60
- +4 ;
- +5 DO NEXT
- IF +DGLST'=15
- if +DGLST=35
- GOTO FIND^DGRPC2
- GOTO @DGLST
- 15 IF $PIECE($GET(^DPT(DFN,.15)),"^",2)]""
- IF $PIECE(DGP(.3),"^",7)=""
- SET X=15
- DO COMB
- +1 DO NEXT
- IF +DGLST'=16
- if +DGLST=35
- GOTO FIND^DGRPC2
- GOTO @DGLST
- 16 DO H^DGUTL
- IF +DGP(.35)>DGTIME
- SET X=16
- DO COMB
- +1 DO NEXT
- IF +DGLST'=17
- if +DGLST=35
- GOTO FIND^DGRPC2
- GOTO @DGLST
- 17 KILL DGDATE,DGTIME
- +1 NEW SDARRAY,SDCLIEN,SDDATE
- +2 SET I1=0
- SET DGD=DT
- +3 SET SDARRAY("FLDS")=3
- +4 SET SDARRAY(4)=DFN
- +5 IF +DGP(.35)
- IF $$SDAPI^SDAMA301(.SDARRAY)
- Begin DoDot:1
- +6 ;if there is data hanging from the 101 subscript,
- +7 ;then this is a valid appointment
- +8 ;otherwise it is an error eg 01/21/2005
- +9 IF $DATA(^TMP($JOB,"SDAMA301",101))=1
- QUIT
- +10 SET SDCLIEN=0
- +11 FOR
- SET SDCLIEN=$ORDER(^TMP($JOB,"SDAMA301",DFN,SDCLIEN))
- if 'SDCLIEN!(I1)
- QUIT
- Begin DoDot:2
- +12 SET SDDATE=0
- +13 FOR
- SET SDDATE=$ORDER(^TMP($JOB,"SDAMA301",DFN,SDCLIEN,SDDATE))
- if 'SDDATE!(I1)
- QUIT
- Begin DoDot:3
- +14 SET X=$PIECE($PIECE(^TMP($JOB,"SDAMA301",DFN,SDCLIEN,SDDATE),"^",3),";")
- +15 IF X=""!(X="I")
- SET I1=1
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +16 KILL ^TMP($JOB,"SDAMA301")
- +17 IF I1
- SET X=17
- DO COMB
- +18 ;
- END ; end of routine...find next check to execute (or goto end)
- +1 if DGNCK
- SET DGLST=35
- if DGCHK'[",35,"&(DGNCK)
- GOTO FIND^DGRPC2
- DO NEXT
- GOTO @DGLST
- +2 ;
- COMB ;record inconsistency
- +1 SET DGCT=DGCT+1
- SET DGER=DGER_X_","
- SET DGLST=X
- QUIT
- +2 QUIT
- +3 ;
- NEXT ; find the next consistency check to check (goto end if can't process further)
- +1 SET I=$FIND(DGCHK,(","_DGLST_","))
- SET DGLST=+$EXTRACT(DGCHK,I,999)
- IF +DGLST
- IF DGLST<18
- QUIT
- +2 IF +DGLST
- IF DGNCK
- IF +DGLST>17
- IF +DGLST<36
- SET DGLST=35
- if DGCHK'[",35,"
- QUIT
- GOTO NEXT
- +3 if '+DGLST
- SET DGLST="END^DGRPC3"
- IF +DGLST
- SET DGLST=DGLST_"^DGRPC"_$SELECT(+DGLST<43:1,+DGLST<79:2,1:3)
- +4 QUIT
- +5 ;
- PAT ;check inconsistencies for a selected patient
- +1 DO ON
- if DGER
- GOTO KVAR^DGRPCE
- WRITE !!
- SET DIC="^DPT("
- SET DIC(0)="AEQMZ"
- SET DIC("A")="Check consistency for which PATIENT: "
- DO ^DIC
- KILL DIC
- if Y'>0
- GOTO KVAR^DGRPCE
- SET DFN=+Y
- SET DGEDCN=1
- DO DGRPC
- GOTO PAT
- +2 ;
- START ;record start time for checker
- +1 SET DGSTART=$HOROLOG
- QUIT
- +2 ;
- TIME ;record end time for checker
- +1 if '$DATA(DGSTART)#2
- QUIT
- SET DGEND=$HOROLOG
- SET X=$PIECE(DGSTART,",",2)
- SET X1=$PIECE(DGEND,",",2)
- +2 IF +DGSTART=+DGEND
- SET DGTIME=X1-X
- +3 IF '$TEST
- SET DGTIME=(5184000-X)+X1
- +4 IF $SELECT(DGCT:0,DGCON=1:1,1:0)
- GOTO TIMEQ
- +5 WRITE !!,"===> ",$SELECT(DGCT:DGCT,DGCON<2:"No",1:"All")," inconsistenc",$SELECT(DGCT=1:"y",1:"ies")," ",$SELECT('DGCON:"found",DGCON=1:"filed",1:"removed")," in ",DGTIME," second",$SELECT(DGTIME=1:"",1:"s"),"..."
- HANG 1
- TIMEQ KILL DGSTART,DGEND,DGTIME,X,X1,DGCON
- QUIT
- +1 ;
- ON ;check if checker is on
- +1 SET DGER=0
- IF $SELECT('$DATA(^DG(43,1,0)):1,'$PIECE(^(0),"^",37):1,1:0)
- SET DGER=1
- +2 if '$DATA(DGEDCN)
- SET DGEDCN=0
- if DGER
- WRITE !!,"CONSISTENCY CHECKER TURNED OFF!!",$CHAR(7)
- QUIT
- VETINDCHG ; DG*5.3*1027 Vet indicator change
- +1 ; If DO YOU WISH TO ENROLL field in PATIENT (#2) file is YES AND
- +2 ; A record for the patient does not exist in the Patient Enrollment file AND
- +3 ; The patient is unknown to ES Then Incomplete Enrollment.
- +4 ; Supported DBIA #2701: The supported DBIA is used to access MPI
- +5 ; APIs to retrieve ICN, determine if ICN
- +6 ; is local and if site is LST.
- +7 ; Supported ICRs
- +8 ; #3356 - XQY0 ; Kernel Variable
- +9 ;
- +10 ; Quit if not in specific menu options or if there is a current enrollment
- +11 IF ($PIECE($GET(XQY0),"^",1)'="DG REGISTER PATIENT")
- IF ($PIECE($GET(XQY0),"^",1)'="DG LOAD PATIENT DATA")
- IF ($PIECE($GET(XQY0),"^",1)'="DG ELIGIBILITY VERIFICATION")
- IF ($PIECE($GET(XQY0),"^",1)'="DGPRE PRE-REGISTER OPTION")
- QUIT
- +12 IF $$FINDCUR^DGENA(DFN)
- QUIT
- +13 NEW DGKEY,DGREQNAME,DGENSTAT,DGWSHTOEN,DGRESP,DGVET,DGOVET,DTOUT,DUOUT
- +14 SET DGREQNAME="VistAData"
- +15 SET DGRESP=0
- +16 SET DGKEY=$$GETICN^MPIF001(DFN)
- SET DGVET=$$VET^DGENPTA(DFN)
- SET DGOVET=$GET(^TMP($JOB,"DGOLDVET",DFN))
- +17 IF $PIECE(DGKEY,"^",1)'=-1
- SET DGRESP=$$EN^DGREGEEWS(DGKEY,DGREQNAME,.DGENSTAT,.DGWSHTOEN)
- +18 IF +DGRESP=0
- IF '$GET(DGDONE)
- IF $PIECE($GET(XQY0),"^",1)'="DG REGISTER PATIENT"
- Begin DoDot:1
- +19 WRITE !!,"This patient has not had the Enrollment Request Process completed and this must be done through Register A Patient."
- +20 SET DGDONE=1
- +21 NEW DIR,X,Y
- +22 SET DIR(0)="E"
- +23 DO ^DIR
- KILL DIR
- End DoDot:1
- +24 IF DGOVET'=""
- IF $PIECE($GET(XQY0),"^",1)="DG REGISTER PATIENT"
- IF +DGRESP=0
- IF DGVET'=DGOVET
- IF '$GET(DGDONE2)
- Begin DoDot:1
- +25 IF DGVET=1
- Begin DoDot:2
- +26 WRITE !,"Veteran indicator has been changed. ""Do You Wish To Enroll"" is currently set to NO."
- +27 WRITE !!,"Use the Enrollment System if the Veteran wishes to enroll."
- +28 NEW DIR,X,Y
- +29 SET DIR(0)="E"
- +30 DO ^DIR
- End DoDot:2
- +31 IF DGVET=0
- Begin DoDot:2
- +32 NEW DGINELIG,DGENPTA
- +33 IF $$GET^DGENPTA(DFN,.DGENPTA)
- SET DGINELIG=$GET(DGENPTA("INELDATE"))
- +34 ;self-reported reason prompt
- IF ($GET(DGENRYN)=1)
- IF DGINELIG=""
- DO REGORSN
- +35 ; DG*5.3*1045 - If there is no Ineligible Date, set the Appointment request fields to null
- IF DGINELIG=""
- DO APPTCHG
- End DoDot:2
- +36 SET DGDONE2=1
- End DoDot:1
- +37 QUIT
- APPTCHG ; DG*5.3*1027 Vet indicator change from Yes to No
- +1 ;Remove the Appointment Request information
- +2 NEW DGIENS,DGRSLT,DGFDA
- +3 SET DGRSLT=""
- +4 SET DGIENS=DFN_","
- +5 ;APPOINTMENT REQUEST ON 1010EZ 1010.15;9
- +6 ;
- SET DGFDA(2,DGIENS,1010.159)=DGRSLT
- +7 ;APPOINTMENT REQUEST DATE 1010.15;11
- +8 SET DGFDA(2,DGIENS,1010.1511)=DGRSLT
- +9 ;ORIGINAL APPOINTMENT REQUEST 1010.15;12
- +10 SET DGFDA(2,DGIENS,1010.1512)=DGRSLT
- +11 ;ORIGINAL APPT REQUEST DATE 1010.15;13
- +12 SET DGFDA(2,DGIENS,1010.1513)=DGRSLT
- +13 ;ORIG APPT REQUEST CHG DT/TM 1010.15;14
- +14 SET DGFDA(2,DGIENS,1010.1514)=DGRSLT
- +15 ;APPT REQUEST 1010EZ CHG DT/TM 1010.15;15
- +16 SET DGFDA(2,DGIENS,1010.1515)=DGRSLT
- +17 DO FILE^DIE("","DGFDA")
- +18 QUIT
- REGORSN ; DG*5.3*1027 Display prompt for REGISTRATION ONLY REASON
- +1 NEW DGNOW,DGENRODT,DGENSRCE,DGENRRSN,DIR,X,Y,DUOUT,DTOUT
- +2 FOR
- Begin DoDot:1
- +3 KILL DIR
- +4 SET DIR("A")="SELF-REPORTED REGISTRATION ONLY REASON: "
- +5 SET DIR(0)="27.11,.15,AO"
- +6 DO ^DIR
- if $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +7 SET DGENRRSN=+Y
- +8 IF 'DGENRRSN
- WRITE !,"This is a required field.",!
- End DoDot:1
- if DGENRRSN
- QUIT
- +9 IF DGENRRSN
- SET DGNOW=$$NOW^XLFDT()
- SET DGENRODT=DGNOW
- SET DGENSRCE=1
- DO REGONLY^DGEN(DFN)
- +10 SET DGENRYN=0
- +11 QUIT