DGENUPL8 ;ISA/KWP,RTK,PHH,ERC,KUM,JAM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;03/11/20 12:41pm
;;5.3;REGISTRATION;**232,266,327,314,365,417,514,688,940,952,993,1111**;Aug 13,1993;Build 18
;Per VHA Directive 2004-038, this routine should not be modified.
;
;Moved ENRUPLD from DGENUPL3
;
ENRUPLD(DGENR,DGPAT) ;
;Description: uploads an enrollment receieved from HEC. The consistency
;checks are assumed to have been done, the other patient and eligibility
;data filed already.
;
;Inputs:
; DGENR - enrollment array (pass by reference)
; DGPAT - patient array (pass by reference)
;
;Output: none
;
; DG*5.3*1111 - All ENROLLMENT STATUS (file #27.15) entries of REJECTED renamed to DEFERRED. Comment below modified
;Phase II if HEC sends enrollment statuses VERIFIED(2),UNVERIFIED(1),DEFERRED-FISCAL YEAR(11),DEFERRED-MID-CYCLE(12),DEFERRED-STOP ENROLLING NEW APPLiCANTS(13),PENDING-NO ELIGIBILITY CODE IN VIVA(15)
; PENDING-ELIGIBILITY UNVERIFIED(17),PENDING MEANS TEST REQUIRED(16),PENDING-OTHER(18),NOT ELIGIBLE; REFUSED TO PAY COPAY(19)
; NOT ELIGIBLE; INELIGIBLE DATE(20),PENDING PURPLE HEART UNCONFIRMED(21),DECEASED(6),CANCELED/DECLINED(7),DEFERRED-INITIAL APPLICATION BY VAMC(14),DEFERRED BELOW EGT THRESHOLD(22) then store enrollment (SRS6.5.1.2 f)
;
N CURIEN,CURENR
;
;source should not be VAMC, since it is not a local enrollment
I DGENR("STATUS")'=20 D
. I DGENR("SOURCE")=1 S DGENR("SOURCE")=2
;
;is there a local enrollment?
S CURIEN=$$FINDCUR^DGENA(DGENR("DFN"))
;
;if there is no current enrollment, store HEC enrollment and quit
I 'CURIEN D G EXIT
.;Phase II (SRS 6.5.1.2 f)
.;I "^1^2^6^7^11^12^13^14^15^16^17^18^19^20^21^22^23^24^"[("^"_DGENR("STATUS")_"^") I $$STORECUR^DGENA1(.DGENR,1) ;DJE DG*5.3*940 - Closed Application (status 24) - RM#867186
.I "^1^2^6^7^11^12^13^14^15^16^17^18^19^20^21^22^23^24^25^"[("^"_DGENR("STATUS")_"^") I $$STORECUR^DGENA1(.DGENR,1) ;KUM DG*5.3*1009 - Registration Only (status 25)
I '$$GET^DGENA(CURIEN,.CURENR) D G EXIT
.;Phase II (SRS 6.5.1.2 f)
.;I "^1^2^6^7^11^12^13^14^15^16^17^18^19^20^21^22^23^24^"[("^"_DGENR("STATUS")_"^") I $$STORECUR^DGENA1(.DGENR,1) ;DJE DG*5.3*940 - Closed Application (status 24) - RM#867186
.I "^1^2^6^7^11^12^13^14^15^16^17^18^19^20^21^22^23^24^25^"[("^"_DGENR("STATUS")_"^") I $$STORECUR^DGENA1(.DGENR,1) ;KUM DG*5.3*1009 - Registration Only (status 25)
;
;check for duplicate
Q:$$DUP(.DGENR,.CURENR)
;
;if there is no local enrollment, HEC enrollment becomes current
I CURENR("SOURCE")'=1 D G EXIT
.;Phase II (SRS 6.5.1.2 f)
.;I "^1^2^6^7^11^12^13^14^15^16^17^18^19^20^21^22^23^24^"[("^"_DGENR("STATUS")_"^") I $$STORECUR^DGENA1(.DGENR,1) ;DJE DG*5.3*940 - Closed Application (status 24) - RM#867186
.I "^1^2^6^7^11^12^13^14^15^16^17^18^19^20^21^22^23^24^25^"[("^"_DGENR("STATUS")_"^") I $$STORECUR^DGENA1(.DGENR,1) ;KUM DG*5.3*993 - Registration Only (status 25)
;********************************************************************
;check for exceptions to making HEC enrollment the patient's current enrollment,i.e.,cases in which local enrollment remains the current enrollment
;********************************************************************
;
;if local enrollment has status of Deceased, if the patient is dead and HEC's enrollment doesn't have status of Deceased reject upload
I (CURENR("STATUS")=6),DGENR("STATUS")'=6,DGPAT("DEATH") D G EXIT
.D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),"LOCAL SITE REQUESTED TO VERIFY PATIENT DEATH",.ERRCOUNT)
.; DG*5.3*1111 - Changed REJECTED to DEFERRED.
.D ADDMSG^DGENUPL3(.MSGS,"ELIBILITY UPLOAD DOESN'T CONTAINED DATE OF DEATH AND WAS DEFERRED, PLEASE VERIFY PATIENT DEATH",1)
.D NOTIFY^DGENUPL3(.DGPAT,.MSGS)
.S ERROR=1
;
; DG*5.3*1111 - All ENROLLMENT STATUS (file #27.15) entries of REJECTED renamed to DEFERRED. Comment below modified
;Phase II if local enrollment has status UNVERIFIED(1),DEFERRED-INITIAL APPLICATION BY VAMC(14),PENDING(9)
;and HEC sends status of DEFERRED-FISCAL YEAR(11),DEFERRED-MID-CYCLE(12),DEFERRED-STOP ENROLLING APPLICATIONS(13),PENDING-NO ELIGIBILITY CODE in VIVA(15),DEFERRED BELOW EGT THRESHOLD
;PENDING-ELIGIBILITY UNVERIFIED(17),PENDING-MEANS TEST REQUIRED(16),PENDING-OTHER(18)
;CANCELED/DECLINED(7) accept upload (SRS 6.5.1.2 h)
;I "^1^9^14^"[("^"_CURENR("STATUS")_"^"),"^7^11^12^13^15^16^17^18^19^20^21^22^23^24^"[("^"_DGENR("STATUS")_"^") D G EXIT ;DJE DG*5.3*940 - Closed Application (status 24) - RM#867186
I "^1^9^14^"[("^"_CURENR("STATUS")_"^"),"^7^11^12^13^15^16^17^18^19^20^21^22^23^24^25^"[("^"_DGENR("STATUS")_"^") D G EXIT ;KUM DG*5.3*1009 - Registration Only (status 25)
.I $$STORECUR^DGENA1(.DGENR,1)
;
;if local enrollment has status of Canceled/Declined, HEC enrollment has status of Verified or Unverified, HEC enrollment has an earlier or same effective date accept upload
;I (CURENR("STATUS")=7),"^1^2^24^"[("^"_DGENR("STATUS")_"^"),(CURENR("EFFDATE")'<DGENR("EFFDATE")) D G EXIT ;DJE DG*5.3*940 - Closed Application (status 24) - RM#867186
I (CURENR("STATUS")=7),"^1^2^24^25^"[("^"_DGENR("STATUS")_"^"),(CURENR("EFFDATE")'<DGENR("EFFDATE")) D G EXIT ;KUM DG*5.3*993 - Registration Only (status 25)
.I $$STORECUR^DGENA1(.DGENR,1)
;
;If local enrollment has a status of Unverified(1) and the HEC enrollment
; status is Verified(2), Deceased(6), Cancelled/declined(7) or Pending; Means(16)
; Test Required accept upload
;I "^1^"[("^"_CURENR("STATUS")_"^"),"^2^6^7^16^19^20^21^24^"[("^"_DGENR("STATUS")_"^") D G EXIT ;DJE DG*5.3*940 - Closed Application (status 24) - RM#867186
I "^1^"[("^"_CURENR("STATUS")_"^"),"^2^6^7^16^19^20^21^24^25^"[("^"_DGENR("STATUS")_"^") D G EXIT ;KUM DG*5.3*993 - Registration Only (status 25)
.I $$STORECUR^DGENA1(.DGENR,1)
;
;********************************************************
;end of exceptions
;********************************************************
;
;none of the exceptions apply, so make the HEC enrollment current
;Phase II (SRS 6.5.1.2 f)
;I "^1^2^6^7^11^12^13^14^15^16^17^18^19^20^21^22^24^"[("^"_DGENR("STATUS")_"^") I $$STORECUR^DGENA1(.DGENR,1) ;DJE DG*5.3*940 - Closed Application (status 24) - RM#867186
I "^1^2^6^7^11^12^13^14^15^16^17^18^19^20^21^22^23^24^25^"[("^"_DGENR("STATUS")_"^") I $$STORECUR^DGENA1(.DGENR,1) ;KUM DG*5.3*993 - Registration Only (status 25)
EXIT Q
;
DUP(DGENR1,DGENR2) ;
;Description: returns 1 if the enrollments are duplicates (other than
;audit information), 0 otherwise
;
;Inputs:
; DGENR1, DGENR2 are arrays containing enrollments (pass by reference)
;
;Outputs:
; Function Value: 1 if identical, 0 otherwise
;
N SUB,SAME
S SAME=1
S SUB=""
F S SUB=$O(DGENR1(SUB)) Q:SUB="" D
.Q:(SUB="ELIG")
.Q:(SUB="DATETIME")
.Q:(SUB="USER")
.Q:(SUB="PRIORREC")
.I DGENR1(SUB)'=DGENR2(SUB) S SAME=0
I SAME D
.S SUB=""
.F S SUB=$O(DGENR1("ELIG",SUB)) Q:SUB="" I DGENR1("ELIG",SUB)'=DGENR2("ELIG",SUB) S SAME=0
Q SAME
;
STOREHIS(DGENR,PRIORTO) ;
;Description: Stores the enrollment contained in the DGENR array
; before the enrollment pointed to by PRIORTO.
;
;Inputs:
; DGENR - an array containing an enrollment to be stored
; PRIORTO - ien of the enrollment where the new enrollment should be
; stored. DGENR will be stored as its prior enrollment.
;
Q:'$G(PRIORTO)
;
N DGENRIEN,OK
S OK=1
;
;the new record should point to the record prior to PRIORTO
S DGENR("PRIORREC")=$$FINDPRI^DGENA(PRIORTO)
;
;store the record
S DGENRIEN=$$STORE^DGENA1(.DGENR,1)
I 'DGENRIEN S OK=0
;
;now point the record=PRIORTO to the new record
D:OK
.N DATA
.S DATA(.09)=DGENRIEN
.I $$UPD^DGENDBS(27.11,PRIORTO,.DATA) ;then success
Q
;
OTHUPLD(DFN,DGOTH,DGSSN,PRELIG) ; uploads OTH data. DG*5.3*952
;
; DFN - patient DFN
; DGOTH - OTH array (passed by reference)
; DGSSN - patient SSN
; PRELIG - primary eligibility code
;
; assumes MSGID,ERRCOUNT to be defined in the calling routine
;
N DA,DIK
N CNT,IEN33,IEN3301,QFLG,PNDCRTS,Z
S IEN33=+$O(^DGOTH(33,"B",DFN,"")),QFLG=0
I $$GET1^DIQ(8,PRELIG_",",.01)="EXPANDED MH CARE NON-ENROLLEE",'$$CHKTS(IEN33,.DGOTH) D Q
.D ADDERROR^DGENUPL(MSGID,DGSSN,"VISTA HAS THE MOST RECENT OTH-90 DATA",.ERRCOUNT)
.Q
S PNDCRTS=$$GET1^DIQ(33,IEN33_",",.08,"I")
; pending request
I $G(DGOTH("P"))'="" D
.S Z=$$FILPEND^DGOTHUT1(DFN,"0^^^^^^") I +Z=0 D ADDERROR^DGENUPL(MSGID,DGSSN,$P(Z,U,2),.ERRCOUNT) S QFLG=1 Q
.I $P(DGOTH("P"),U,2)'="@" D
..S Z=$$FILPEND^DGOTHUT1(DFN,DGOTH("P")) I +Z=0 D ADDERROR^DGENUPL(MSGID,DGSSN,$P(Z,U,2),.ERRCOUNT) S QFLG=1
..Q
.Q
I QFLG Q
; re-sort array
D SORTOTH(.DGOTH)
; denied requests
I $D(DGOTH("D"))>0 D Q:QFLG
.; clear sub-file 33.03
.S DIK="^DGOTH(33,"_IEN33_",3,",DA(1)=IEN33
.S DA=0 F S DA=$O(^DGOTH(33,IEN33,3,DA)) Q:'DA D ^DIK
.K DA
.S CNT="" F S CNT=$O(DGOTH("D",CNT)) Q:'CNT!QFLG D
..I $P(DGOTH("D",CNT),U)="@" Q ; skip this entry, if it is marked for deletion
..; if there's a pending request with the same creation timestamp, delete it
..I PNDCRTS=$P(DGOTH("D",CNT),U,5) D Q:QFLG
...S Z=$$FILPEND^DGOTHUT1(DFN,"0^^^^^^") I +Z=0 D ADDERROR^DGENUPL(MSGID,DGSSN,$P(Z,U,2),.ERRCOUNT) S QFLG=1
...Q
..S Z=$$FILDEN^DGOTHUT1(DFN,DGOTH("D",CNT))
..I +Z=0 D ADDERROR^DGENUPL(MSGID,DGSSN,$P(Z,U,2),.ERRCOUNT) S QFLG=1 Q
..Q
.Q
; approved periods
I $D(DGOTH("A"))>0 D Q:QFLG
.S IEN3301=0 F S IEN3301=$O(^DGOTH(33,IEN33,1,IEN3301)) Q:'IEN3301 D
..S DIK="^DGOTH(33,"_IEN33_",1,"_IEN3301_",1,",DA(2)=IEN33,DA(1)=IEN3301
..S DA=0 F S DA=$O(^DGOTH(33,IEN33,1,IEN3301,1,DA)) Q:'DA D ^DIK
..K DA S DIK="^DGOTH(33,"_IEN33_",1,",DA(1)=IEN33,DA=IEN3301 D ^DIK
..Q
.S CNT="" F S CNT=$O(DGOTH("A",CNT)) Q:'CNT!QFLG D
..I $P(DGOTH("A",CNT),U,3)="@" Q ; skip this entry, if it is marked for deletion
..; if there's a pending request with the same creation timestamp, delete it
..I PNDCRTS=$P(DGOTH("A",CNT),U,9) D Q:QFLG
...S Z=$$FILPEND^DGOTHUT1(DFN,"0^^^^^^") I +Z=0 D ADDERROR^DGENUPL(MSGID,DGSSN,$P(Z,U,2),.ERRCOUNT) S QFLG=1
...Q
..S Z=$$FILAUTH^DGOTHUT1(DFN,DGOTH("A",CNT))
..I +Z=0 D ADDERROR^DGENUPL(MSGID,DGSSN,$P(Z,U,2),.ERRCOUNT) S QFLG=1 Q
..Q
.Q
Q
;
CHKTS(IEN33,DGOTH) ; check "last edited" timestamps in file 33 DG*5.3*952
;
; IEN33 - file 33 ien
; DGOTH - OTH array (passed by reference)
;
; returns 0 if the latest timestamp in file 33 is more recent than the latest timestamp in DGOTH, returns 1 otherwise
;
N IENS,LASTTS1,LASTTS2,RES,TMPTS,Z,Z1
S RES=1 I $G(IEN33)'>0 G CHKTSX
S (LASTTS1,LASTTS2)=0
; find the latest timestamp in file 33
S IENS=IEN33_","
S TMPTS=+$$GET1^DIQ(33,IENS,.05,"I") I TMPTS>LASTTS1 S LASTTS1=TMPTS
S Z=0 F S Z=$O(^DGOTH(33,IEN33,1,Z)) Q:'Z D
.S Z1=0 F S Z1=$O(^DGOTH(33,IEN33,1,Z,1,Z1)) Q:'Z1 D
..S IENS=Z1_","_Z_","_IEN33_","
..S TMPTS=+$$GET1^DIQ(33.11,IENS,.06,"I") I TMPTS>LASTTS1 S LASTTS1=TMPTS
..Q
.Q
S Z=0 F S Z=$O(^DGOTH(33,IEN33,3,Z)) Q:'Z D
.S IENS=Z_","_IEN33_","
.S TMPTS=+$$GET1^DIQ(33.03,IENS,.05,"I") I TMPTS>LASTTS1 S LASTTS1=TMPTS
.Q
I LASTTS1=0 G CHKTSX
; find the latest timestamp in DGOTH array
S TMPTS=+$P($G(DGOTH("P")),U,6) I TMPTS>LASTTS2 S LASTTS2=TMPTS
S Z=0 F S Z=$O(DGOTH("A",Z)) Q:'Z S TMPTS=+$P($G(DGOTH("A",Z)),U,10) I TMPTS>LASTTS2 S LASTTS2=TMPTS
S Z=0 F S Z=$O(DGOTH("D",Z)) Q:'Z S TMPTS=+$P($G(DGOTH("D",Z)),U,6) I TMPTS>LASTTS2 S LASTTS2=TMPTS
; compare timestamps
I LASTTS1>LASTTS2 S RES=0
;
CHKTSX ; exit point
Q RES
;
SORTOTH(DGOTH) ; re-sort DGOTH array DG*5.3*952
;
; DGOTH - OTH array (passed by reference)
;
N CNT,TMP,TYPE,VAL,Z,Z1
; sort approved requests by 365 day period # and 90 day period #
; sort denied requests by submission date and creation timestamp
F TYPE="A","D" D
.K TMP S CNT="" F S CNT=$O(DGOTH(TYPE,CNT)) Q:'CNT D
..S VAL=DGOTH(TYPE,CNT),Z=$P(VAL,U),Z1=$P(VAL,U,$S(TYPE="A":2,1:5))
..I Z'="",Z1'="" S TMP(Z,Z1)=VAL
..Q
.K DGOTH(TYPE) S CNT=0
.S Z="" F S Z=$O(TMP(Z)) Q:Z="" D
..S Z1="" F S Z1=$O(TMP(Z,Z1)) Q:Z1="" S CNT=CNT+1,DGOTH(TYPE,CNT)=TMP(Z,Z1)
..Q
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENUPL8 12232 printed Dec 13, 2024@02:43:23 Page 2
DGENUPL8 ;ISA/KWP,RTK,PHH,ERC,KUM,JAM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;03/11/20 12:41pm
+1 ;;5.3;REGISTRATION;**232,266,327,314,365,417,514,688,940,952,993,1111**;Aug 13,1993;Build 18
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;Moved ENRUPLD from DGENUPL3
+5 ;
ENRUPLD(DGENR,DGPAT) ;
+1 ;Description: uploads an enrollment receieved from HEC. The consistency
+2 ;checks are assumed to have been done, the other patient and eligibility
+3 ;data filed already.
+4 ;
+5 ;Inputs:
+6 ; DGENR - enrollment array (pass by reference)
+7 ; DGPAT - patient array (pass by reference)
+8 ;
+9 ;Output: none
+10 ;
+11 ; DG*5.3*1111 - All ENROLLMENT STATUS (file #27.15) entries of REJECTED renamed to DEFERRED. Comment below modified
+12 ;Phase II if HEC sends enrollment statuses VERIFIED(2),UNVERIFIED(1),DEFERRED-FISCAL YEAR(11),DEFERRED-MID-CYCLE(12),DEFERRED-STOP ENROLLING NEW APPLiCANTS(13),PENDING-NO ELIGIBILITY CODE IN VIVA(15)
+13 ; PENDING-ELIGIBILITY UNVERIFIED(17),PENDING MEANS TEST REQUIRED(16),PENDING-OTHER(18),NOT ELIGIBLE; REFUSED TO PAY COPAY(19)
+14 ; NOT ELIGIBLE; INELIGIBLE DATE(20),PENDING PURPLE HEART UNCONFIRMED(21),DECEASED(6),CANCELED/DECLINED(7),DEFERRED-INITIAL APPLICATION BY VAMC(14),DEFERRED BELOW EGT THRESHOLD(22) then store enrollment (SRS6.5.1.2 f)
+15 ;
+16 NEW CURIEN,CURENR
+17 ;
+18 ;source should not be VAMC, since it is not a local enrollment
+19 IF DGENR("STATUS")'=20
Begin DoDot:1
+20 IF DGENR("SOURCE")=1
SET DGENR("SOURCE")=2
End DoDot:1
+21 ;
+22 ;is there a local enrollment?
+23 SET CURIEN=$$FINDCUR^DGENA(DGENR("DFN"))
+24 ;
+25 ;if there is no current enrollment, store HEC enrollment and quit
+26 IF 'CURIEN
Begin DoDot:1
+27 ;Phase II (SRS 6.5.1.2 f)
+28 ;I "^1^2^6^7^11^12^13^14^15^16^17^18^19^20^21^22^23^24^"[("^"_DGENR("STATUS")_"^") I $$STORECUR^DGENA1(.DGENR,1) ;DJE DG*5.3*940 - Closed Application (status 24) - RM#867186
+29 ;KUM DG*5.3*1009 - Registration Only (status 25)
IF "^1^2^6^7^11^12^13^14^15^16^17^18^19^20^21^22^23^24^25^"[("^"_DGENR("STATUS")_"^")
IF $$STORECUR^DGENA1(.DGENR,1)
End DoDot:1
GOTO EXIT
+30 IF '$$GET^DGENA(CURIEN,.CURENR)
Begin DoDot:1
+31 ;Phase II (SRS 6.5.1.2 f)
+32 ;I "^1^2^6^7^11^12^13^14^15^16^17^18^19^20^21^22^23^24^"[("^"_DGENR("STATUS")_"^") I $$STORECUR^DGENA1(.DGENR,1) ;DJE DG*5.3*940 - Closed Application (status 24) - RM#867186
+33 ;KUM DG*5.3*1009 - Registration Only (status 25)
IF "^1^2^6^7^11^12^13^14^15^16^17^18^19^20^21^22^23^24^25^"[("^"_DGENR("STATUS")_"^")
IF $$STORECUR^DGENA1(.DGENR,1)
End DoDot:1
GOTO EXIT
+34 ;
+35 ;check for duplicate
+36 if $$DUP(.DGENR,.CURENR)
QUIT
+37 ;
+38 ;if there is no local enrollment, HEC enrollment becomes current
+39 IF CURENR("SOURCE")'=1
Begin DoDot:1
+40 ;Phase II (SRS 6.5.1.2 f)
+41 ;I "^1^2^6^7^11^12^13^14^15^16^17^18^19^20^21^22^23^24^"[("^"_DGENR("STATUS")_"^") I $$STORECUR^DGENA1(.DGENR,1) ;DJE DG*5.3*940 - Closed Application (status 24) - RM#867186
+42 ;KUM DG*5.3*993 - Registration Only (status 25)
IF "^1^2^6^7^11^12^13^14^15^16^17^18^19^20^21^22^23^24^25^"[("^"_DGENR("STATUS")_"^")
IF $$STORECUR^DGENA1(.DGENR,1)
End DoDot:1
GOTO EXIT
+43 ;********************************************************************
+44 ;check for exceptions to making HEC enrollment the patient's current enrollment,i.e.,cases in which local enrollment remains the current enrollment
+45 ;********************************************************************
+46 ;
+47 ;if local enrollment has status of Deceased, if the patient is dead and HEC's enrollment doesn't have status of Deceased reject upload
+48 IF (CURENR("STATUS")=6)
IF DGENR("STATUS")'=6
IF DGPAT("DEATH")
Begin DoDot:1
+49 DO ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),"LOCAL SITE REQUESTED TO VERIFY PATIENT DEATH",.ERRCOUNT)
+50 ; DG*5.3*1111 - Changed REJECTED to DEFERRED.
+51 DO ADDMSG^DGENUPL3(.MSGS,"ELIBILITY UPLOAD DOESN'T CONTAINED DATE OF DEATH AND WAS DEFERRED, PLEASE VERIFY PATIENT DEATH",1)
+52 DO NOTIFY^DGENUPL3(.DGPAT,.MSGS)
+53 SET ERROR=1
End DoDot:1
GOTO EXIT
+54 ;
+55 ; DG*5.3*1111 - All ENROLLMENT STATUS (file #27.15) entries of REJECTED renamed to DEFERRED. Comment below modified
+56 ;Phase II if local enrollment has status UNVERIFIED(1),DEFERRED-INITIAL APPLICATION BY VAMC(14),PENDING(9)
+57 ;and HEC sends status of DEFERRED-FISCAL YEAR(11),DEFERRED-MID-CYCLE(12),DEFERRED-STOP ENROLLING APPLICATIONS(13),PENDING-NO ELIGIBILITY CODE in VIVA(15),DEFERRED BELOW EGT THRESHOLD
+58 ;PENDING-ELIGIBILITY UNVERIFIED(17),PENDING-MEANS TEST REQUIRED(16),PENDING-OTHER(18)
+59 ;CANCELED/DECLINED(7) accept upload (SRS 6.5.1.2 h)
+60 ;I "^1^9^14^"[("^"_CURENR("STATUS")_"^"),"^7^11^12^13^15^16^17^18^19^20^21^22^23^24^"[("^"_DGENR("STATUS")_"^") D G EXIT ;DJE DG*5.3*940 - Closed Application (status 24) - RM#867186
+61 ;KUM DG*5.3*1009 - Registration Only (status 25)
IF "^1^9^14^"[("^"_CURENR("STATUS")_"^")
IF "^7^11^12^13^15^16^17^18^19^20^21^22^23^24^25^"[("^"_DGENR("STATUS")_"^")
Begin DoDot:1
+62 IF $$STORECUR^DGENA1(.DGENR,1)
End DoDot:1
GOTO EXIT
+63 ;
+64 ;if local enrollment has status of Canceled/Declined, HEC enrollment has status of Verified or Unverified, HEC enrollment has an earlier or same effective date accept upload
+65 ;I (CURENR("STATUS")=7),"^1^2^24^"[("^"_DGENR("STATUS")_"^"),(CURENR("EFFDATE")'<DGENR("EFFDATE")) D G EXIT ;DJE DG*5.3*940 - Closed Application (status 24) - RM#867186
+66 ;KUM DG*5.3*993 - Registration Only (status 25)
IF (CURENR("STATUS")=7)
IF "^1^2^24^25^"[("^"_DGENR("STATUS")_"^")
IF (CURENR("EFFDATE")'<DGENR("EFFDATE"))
Begin DoDot:1
+67 IF $$STORECUR^DGENA1(.DGENR,1)
End DoDot:1
GOTO EXIT
+68 ;
+69 ;If local enrollment has a status of Unverified(1) and the HEC enrollment
+70 ; status is Verified(2), Deceased(6), Cancelled/declined(7) or Pending; Means(16)
+71 ; Test Required accept upload
+72 ;I "^1^"[("^"_CURENR("STATUS")_"^"),"^2^6^7^16^19^20^21^24^"[("^"_DGENR("STATUS")_"^") D G EXIT ;DJE DG*5.3*940 - Closed Application (status 24) - RM#867186
+73 ;KUM DG*5.3*993 - Registration Only (status 25)
IF "^1^"[("^"_CURENR("STATUS")_"^")
IF "^2^6^7^16^19^20^21^24^25^"[("^"_DGENR("STATUS")_"^")
Begin DoDot:1
+74 IF $$STORECUR^DGENA1(.DGENR,1)
End DoDot:1
GOTO EXIT
+75 ;
+76 ;********************************************************
+77 ;end of exceptions
+78 ;********************************************************
+79 ;
+80 ;none of the exceptions apply, so make the HEC enrollment current
+81 ;Phase II (SRS 6.5.1.2 f)
+82 ;I "^1^2^6^7^11^12^13^14^15^16^17^18^19^20^21^22^24^"[("^"_DGENR("STATUS")_"^") I $$STORECUR^DGENA1(.DGENR,1) ;DJE DG*5.3*940 - Closed Application (status 24) - RM#867186
+83 ;KUM DG*5.3*993 - Registration Only (status 25)
IF "^1^2^6^7^11^12^13^14^15^16^17^18^19^20^21^22^23^24^25^"[("^"_DGENR("STATUS")_"^")
IF $$STORECUR^DGENA1(.DGENR,1)
EXIT QUIT
+1 ;
DUP(DGENR1,DGENR2) ;
+1 ;Description: returns 1 if the enrollments are duplicates (other than
+2 ;audit information), 0 otherwise
+3 ;
+4 ;Inputs:
+5 ; DGENR1, DGENR2 are arrays containing enrollments (pass by reference)
+6 ;
+7 ;Outputs:
+8 ; Function Value: 1 if identical, 0 otherwise
+9 ;
+10 NEW SUB,SAME
+11 SET SAME=1
+12 SET SUB=""
+13 FOR
SET SUB=$ORDER(DGENR1(SUB))
if SUB=""
QUIT
Begin DoDot:1
+14 if (SUB="ELIG")
QUIT
+15 if (SUB="DATETIME")
QUIT
+16 if (SUB="USER")
QUIT
+17 if (SUB="PRIORREC")
QUIT
+18 IF DGENR1(SUB)'=DGENR2(SUB)
SET SAME=0
End DoDot:1
+19 IF SAME
Begin DoDot:1
+20 SET SUB=""
+21 FOR
SET SUB=$ORDER(DGENR1("ELIG",SUB))
if SUB=""
QUIT
IF DGENR1("ELIG",SUB)'=DGENR2("ELIG",SUB)
SET SAME=0
End DoDot:1
+22 QUIT SAME
+23 ;
STOREHIS(DGENR,PRIORTO) ;
+1 ;Description: Stores the enrollment contained in the DGENR array
+2 ; before the enrollment pointed to by PRIORTO.
+3 ;
+4 ;Inputs:
+5 ; DGENR - an array containing an enrollment to be stored
+6 ; PRIORTO - ien of the enrollment where the new enrollment should be
+7 ; stored. DGENR will be stored as its prior enrollment.
+8 ;
+9 if '$GET(PRIORTO)
QUIT
+10 ;
+11 NEW DGENRIEN,OK
+12 SET OK=1
+13 ;
+14 ;the new record should point to the record prior to PRIORTO
+15 SET DGENR("PRIORREC")=$$FINDPRI^DGENA(PRIORTO)
+16 ;
+17 ;store the record
+18 SET DGENRIEN=$$STORE^DGENA1(.DGENR,1)
+19 IF 'DGENRIEN
SET OK=0
+20 ;
+21 ;now point the record=PRIORTO to the new record
+22 if OK
Begin DoDot:1
+23 NEW DATA
+24 SET DATA(.09)=DGENRIEN
+25 ;then success
IF $$UPD^DGENDBS(27.11,PRIORTO,.DATA)
End DoDot:1
+26 QUIT
+27 ;
OTHUPLD(DFN,DGOTH,DGSSN,PRELIG) ; uploads OTH data. DG*5.3*952
+1 ;
+2 ; DFN - patient DFN
+3 ; DGOTH - OTH array (passed by reference)
+4 ; DGSSN - patient SSN
+5 ; PRELIG - primary eligibility code
+6 ;
+7 ; assumes MSGID,ERRCOUNT to be defined in the calling routine
+8 ;
+9 NEW DA,DIK
+10 NEW CNT,IEN33,IEN3301,QFLG,PNDCRTS,Z
+11 SET IEN33=+$ORDER(^DGOTH(33,"B",DFN,""))
SET QFLG=0
+12 IF $$GET1^DIQ(8,PRELIG_",",.01)="EXPANDED MH CARE NON-ENROLLEE"
IF '$$CHKTS(IEN33,.DGOTH)
Begin DoDot:1
+13 DO ADDERROR^DGENUPL(MSGID,DGSSN,"VISTA HAS THE MOST RECENT OTH-90 DATA",.ERRCOUNT)
+14 QUIT
End DoDot:1
QUIT
+15 SET PNDCRTS=$$GET1^DIQ(33,IEN33_",",.08,"I")
+16 ; pending request
+17 IF $GET(DGOTH("P"))'=""
Begin DoDot:1
+18 SET Z=$$FILPEND^DGOTHUT1(DFN,"0^^^^^^")
IF +Z=0
DO ADDERROR^DGENUPL(MSGID,DGSSN,$PIECE(Z,U,2),.ERRCOUNT)
SET QFLG=1
QUIT
+19 IF $PIECE(DGOTH("P"),U,2)'="@"
Begin DoDot:2
+20 SET Z=$$FILPEND^DGOTHUT1(DFN,DGOTH("P"))
IF +Z=0
DO ADDERROR^DGENUPL(MSGID,DGSSN,$PIECE(Z,U,2),.ERRCOUNT)
SET QFLG=1
+21 QUIT
End DoDot:2
+22 QUIT
End DoDot:1
+23 IF QFLG
QUIT
+24 ; re-sort array
+25 DO SORTOTH(.DGOTH)
+26 ; denied requests
+27 IF $DATA(DGOTH("D"))>0
Begin DoDot:1
+28 ; clear sub-file 33.03
+29 SET DIK="^DGOTH(33,"_IEN33_",3,"
SET DA(1)=IEN33
+30 SET DA=0
FOR
SET DA=$ORDER(^DGOTH(33,IEN33,3,DA))
if 'DA
QUIT
DO ^DIK
+31 KILL DA
+32 SET CNT=""
FOR
SET CNT=$ORDER(DGOTH("D",CNT))
if 'CNT!QFLG
QUIT
Begin DoDot:2
+33 ; skip this entry, if it is marked for deletion
IF $PIECE(DGOTH("D",CNT),U)="@"
QUIT
+34 ; if there's a pending request with the same creation timestamp, delete it
+35 IF PNDCRTS=$PIECE(DGOTH("D",CNT),U,5)
Begin DoDot:3
+36 SET Z=$$FILPEND^DGOTHUT1(DFN,"0^^^^^^")
IF +Z=0
DO ADDERROR^DGENUPL(MSGID,DGSSN,$PIECE(Z,U,2),.ERRCOUNT)
SET QFLG=1
+37 QUIT
End DoDot:3
if QFLG
QUIT
+38 SET Z=$$FILDEN^DGOTHUT1(DFN,DGOTH("D",CNT))
+39 IF +Z=0
DO ADDERROR^DGENUPL(MSGID,DGSSN,$PIECE(Z,U,2),.ERRCOUNT)
SET QFLG=1
QUIT
+40 QUIT
End DoDot:2
+41 QUIT
End DoDot:1
if QFLG
QUIT
+42 ; approved periods
+43 IF $DATA(DGOTH("A"))>0
Begin DoDot:1
+44 SET IEN3301=0
FOR
SET IEN3301=$ORDER(^DGOTH(33,IEN33,1,IEN3301))
if 'IEN3301
QUIT
Begin DoDot:2
+45 SET DIK="^DGOTH(33,"_IEN33_",1,"_IEN3301_",1,"
SET DA(2)=IEN33
SET DA(1)=IEN3301
+46 SET DA=0
FOR
SET DA=$ORDER(^DGOTH(33,IEN33,1,IEN3301,1,DA))
if 'DA
QUIT
DO ^DIK
+47 KILL DA
SET DIK="^DGOTH(33,"_IEN33_",1,"
SET DA(1)=IEN33
SET DA=IEN3301
DO ^DIK
+48 QUIT
End DoDot:2
+49 SET CNT=""
FOR
SET CNT=$ORDER(DGOTH("A",CNT))
if 'CNT!QFLG
QUIT
Begin DoDot:2
+50 ; skip this entry, if it is marked for deletion
IF $PIECE(DGOTH("A",CNT),U,3)="@"
QUIT
+51 ; if there's a pending request with the same creation timestamp, delete it
+52 IF PNDCRTS=$PIECE(DGOTH("A",CNT),U,9)
Begin DoDot:3
+53 SET Z=$$FILPEND^DGOTHUT1(DFN,"0^^^^^^")
IF +Z=0
DO ADDERROR^DGENUPL(MSGID,DGSSN,$PIECE(Z,U,2),.ERRCOUNT)
SET QFLG=1
+54 QUIT
End DoDot:3
if QFLG
QUIT
+55 SET Z=$$FILAUTH^DGOTHUT1(DFN,DGOTH("A",CNT))
+56 IF +Z=0
DO ADDERROR^DGENUPL(MSGID,DGSSN,$PIECE(Z,U,2),.ERRCOUNT)
SET QFLG=1
QUIT
+57 QUIT
End DoDot:2
+58 QUIT
End DoDot:1
if QFLG
QUIT
+59 QUIT
+60 ;
CHKTS(IEN33,DGOTH) ; check "last edited" timestamps in file 33 DG*5.3*952
+1 ;
+2 ; IEN33 - file 33 ien
+3 ; DGOTH - OTH array (passed by reference)
+4 ;
+5 ; returns 0 if the latest timestamp in file 33 is more recent than the latest timestamp in DGOTH, returns 1 otherwise
+6 ;
+7 NEW IENS,LASTTS1,LASTTS2,RES,TMPTS,Z,Z1
+8 SET RES=1
IF $GET(IEN33)'>0
GOTO CHKTSX
+9 SET (LASTTS1,LASTTS2)=0
+10 ; find the latest timestamp in file 33
+11 SET IENS=IEN33_","
+12 SET TMPTS=+$$GET1^DIQ(33,IENS,.05,"I")
IF TMPTS>LASTTS1
SET LASTTS1=TMPTS
+13 SET Z=0
FOR
SET Z=$ORDER(^DGOTH(33,IEN33,1,Z))
if 'Z
QUIT
Begin DoDot:1
+14 SET Z1=0
FOR
SET Z1=$ORDER(^DGOTH(33,IEN33,1,Z,1,Z1))
if 'Z1
QUIT
Begin DoDot:2
+15 SET IENS=Z1_","_Z_","_IEN33_","
+16 SET TMPTS=+$$GET1^DIQ(33.11,IENS,.06,"I")
IF TMPTS>LASTTS1
SET LASTTS1=TMPTS
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 SET Z=0
FOR
SET Z=$ORDER(^DGOTH(33,IEN33,3,Z))
if 'Z
QUIT
Begin DoDot:1
+20 SET IENS=Z_","_IEN33_","
+21 SET TMPTS=+$$GET1^DIQ(33.03,IENS,.05,"I")
IF TMPTS>LASTTS1
SET LASTTS1=TMPTS
+22 QUIT
End DoDot:1
+23 IF LASTTS1=0
GOTO CHKTSX
+24 ; find the latest timestamp in DGOTH array
+25 SET TMPTS=+$PIECE($GET(DGOTH("P")),U,6)
IF TMPTS>LASTTS2
SET LASTTS2=TMPTS
+26 SET Z=0
FOR
SET Z=$ORDER(DGOTH("A",Z))
if 'Z
QUIT
SET TMPTS=+$PIECE($GET(DGOTH("A",Z)),U,10)
IF TMPTS>LASTTS2
SET LASTTS2=TMPTS
+27 SET Z=0
FOR
SET Z=$ORDER(DGOTH("D",Z))
if 'Z
QUIT
SET TMPTS=+$PIECE($GET(DGOTH("D",Z)),U,6)
IF TMPTS>LASTTS2
SET LASTTS2=TMPTS
+28 ; compare timestamps
+29 IF LASTTS1>LASTTS2
SET RES=0
+30 ;
CHKTSX ; exit point
+1 QUIT RES
+2 ;
SORTOTH(DGOTH) ; re-sort DGOTH array DG*5.3*952
+1 ;
+2 ; DGOTH - OTH array (passed by reference)
+3 ;
+4 NEW CNT,TMP,TYPE,VAL,Z,Z1
+5 ; sort approved requests by 365 day period # and 90 day period #
+6 ; sort denied requests by submission date and creation timestamp
+7 FOR TYPE="A","D"
Begin DoDot:1
+8 KILL TMP
SET CNT=""
FOR
SET CNT=$ORDER(DGOTH(TYPE,CNT))
if 'CNT
QUIT
Begin DoDot:2
+9 SET VAL=DGOTH(TYPE,CNT)
SET Z=$PIECE(VAL,U)
SET Z1=$PIECE(VAL,U,$SELECT(TYPE="A":2,1:5))
+10 IF Z'=""
IF Z1'=""
SET TMP(Z,Z1)=VAL
+11 QUIT
End DoDot:2
+12 KILL DGOTH(TYPE)
SET CNT=0
+13 SET Z=""
FOR
SET Z=$ORDER(TMP(Z))
if Z=""
QUIT
Begin DoDot:2
+14 SET Z1=""
FOR
SET Z1=$ORDER(TMP(Z,Z1))
if Z1=""
QUIT
SET CNT=CNT+1
SET DGOTH(TYPE,CNT)=TMP(Z,Z1)
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 QUIT
