- 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 Feb 19, 2025@00:09:26 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