Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGENUPL8

DGENUPL8.m

Go to the documentation of this file.
  1. 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
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ;Moved ENRUPLD from DGENUPL3
  1. ;
  1. ENRUPLD(DGENR,DGPAT) ;
  1. ;Description: uploads an enrollment receieved from HEC. The consistency
  1. ;checks are assumed to have been done, the other patient and eligibility
  1. ;data filed already.
  1. ;
  1. ;Inputs:
  1. ; DGENR - enrollment array (pass by reference)
  1. ; DGPAT - patient array (pass by reference)
  1. ;
  1. ;Output: none
  1. ;
  1. ; DG*5.3*1111 - All ENROLLMENT STATUS (file #27.15) entries of REJECTED renamed to DEFERRED. Comment below modified
  1. ;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)
  1. ; PENDING-ELIGIBILITY UNVERIFIED(17),PENDING MEANS TEST REQUIRED(16),PENDING-OTHER(18),NOT ELIGIBLE; REFUSED TO PAY COPAY(19)
  1. ; 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)
  1. ;
  1. N CURIEN,CURENR
  1. ;
  1. ;source should not be VAMC, since it is not a local enrollment
  1. I DGENR("STATUS")'=20 D
  1. . I DGENR("SOURCE")=1 S DGENR("SOURCE")=2
  1. ;
  1. ;is there a local enrollment?
  1. S CURIEN=$$FINDCUR^DGENA(DGENR("DFN"))
  1. ;
  1. ;if there is no current enrollment, store HEC enrollment and quit
  1. I 'CURIEN D G EXIT
  1. .;Phase II (SRS 6.5.1.2 f)
  1. .;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
  1. .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)
  1. I '$$GET^DGENA(CURIEN,.CURENR) D G EXIT
  1. .;Phase II (SRS 6.5.1.2 f)
  1. .;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
  1. .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)
  1. ;
  1. ;check for duplicate
  1. Q:$$DUP(.DGENR,.CURENR)
  1. ;
  1. ;if there is no local enrollment, HEC enrollment becomes current
  1. I CURENR("SOURCE")'=1 D G EXIT
  1. .;Phase II (SRS 6.5.1.2 f)
  1. .;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
  1. .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)
  1. ;********************************************************************
  1. ;check for exceptions to making HEC enrollment the patient's current enrollment,i.e.,cases in which local enrollment remains the current enrollment
  1. ;********************************************************************
  1. ;
  1. ;if local enrollment has status of Deceased, if the patient is dead and HEC's enrollment doesn't have status of Deceased reject upload
  1. I (CURENR("STATUS")=6),DGENR("STATUS")'=6,DGPAT("DEATH") D G EXIT
  1. .D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),"LOCAL SITE REQUESTED TO VERIFY PATIENT DEATH",.ERRCOUNT)
  1. .; DG*5.3*1111 - Changed REJECTED to DEFERRED.
  1. .D ADDMSG^DGENUPL3(.MSGS,"ELIBILITY UPLOAD DOESN'T CONTAINED DATE OF DEATH AND WAS DEFERRED, PLEASE VERIFY PATIENT DEATH",1)
  1. .D NOTIFY^DGENUPL3(.DGPAT,.MSGS)
  1. .S ERROR=1
  1. ;
  1. ; DG*5.3*1111 - All ENROLLMENT STATUS (file #27.15) entries of REJECTED renamed to DEFERRED. Comment below modified
  1. ;Phase II if local enrollment has status UNVERIFIED(1),DEFERRED-INITIAL APPLICATION BY VAMC(14),PENDING(9)
  1. ;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
  1. ;PENDING-ELIGIBILITY UNVERIFIED(17),PENDING-MEANS TEST REQUIRED(16),PENDING-OTHER(18)
  1. ;CANCELED/DECLINED(7) accept upload (SRS 6.5.1.2 h)
  1. ;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
  1. 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)
  1. .I $$STORECUR^DGENA1(.DGENR,1)
  1. ;
  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
  1. ;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
  1. 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)
  1. .I $$STORECUR^DGENA1(.DGENR,1)
  1. ;
  1. ;If local enrollment has a status of Unverified(1) and the HEC enrollment
  1. ; status is Verified(2), Deceased(6), Cancelled/declined(7) or Pending; Means(16)
  1. ; Test Required accept upload
  1. ;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
  1. 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)
  1. .I $$STORECUR^DGENA1(.DGENR,1)
  1. ;
  1. ;********************************************************
  1. ;end of exceptions
  1. ;********************************************************
  1. ;
  1. ;none of the exceptions apply, so make the HEC enrollment current
  1. ;Phase II (SRS 6.5.1.2 f)
  1. ;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
  1. 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)
  1. EXIT Q
  1. ;
  1. DUP(DGENR1,DGENR2) ;
  1. ;Description: returns 1 if the enrollments are duplicates (other than
  1. ;audit information), 0 otherwise
  1. ;
  1. ;Inputs:
  1. ; DGENR1, DGENR2 are arrays containing enrollments (pass by reference)
  1. ;
  1. ;Outputs:
  1. ; Function Value: 1 if identical, 0 otherwise
  1. ;
  1. N SUB,SAME
  1. S SAME=1
  1. S SUB=""
  1. F S SUB=$O(DGENR1(SUB)) Q:SUB="" D
  1. .Q:(SUB="ELIG")
  1. .Q:(SUB="DATETIME")
  1. .Q:(SUB="USER")
  1. .Q:(SUB="PRIORREC")
  1. .I DGENR1(SUB)'=DGENR2(SUB) S SAME=0
  1. I SAME D
  1. .S SUB=""
  1. .F S SUB=$O(DGENR1("ELIG",SUB)) Q:SUB="" I DGENR1("ELIG",SUB)'=DGENR2("ELIG",SUB) S SAME=0
  1. Q SAME
  1. ;
  1. STOREHIS(DGENR,PRIORTO) ;
  1. ;Description: Stores the enrollment contained in the DGENR array
  1. ; before the enrollment pointed to by PRIORTO.
  1. ;
  1. ;Inputs:
  1. ; DGENR - an array containing an enrollment to be stored
  1. ; PRIORTO - ien of the enrollment where the new enrollment should be
  1. ; stored. DGENR will be stored as its prior enrollment.
  1. ;
  1. Q:'$G(PRIORTO)
  1. ;
  1. N DGENRIEN,OK
  1. S OK=1
  1. ;
  1. ;the new record should point to the record prior to PRIORTO
  1. S DGENR("PRIORREC")=$$FINDPRI^DGENA(PRIORTO)
  1. ;
  1. ;store the record
  1. S DGENRIEN=$$STORE^DGENA1(.DGENR,1)
  1. I 'DGENRIEN S OK=0
  1. ;
  1. ;now point the record=PRIORTO to the new record
  1. D:OK
  1. .N DATA
  1. .S DATA(.09)=DGENRIEN
  1. .I $$UPD^DGENDBS(27.11,PRIORTO,.DATA) ;then success
  1. Q
  1. ;
  1. OTHUPLD(DFN,DGOTH,DGSSN,PRELIG) ; uploads OTH data. DG*5.3*952
  1. ;
  1. ; DFN - patient DFN
  1. ; DGOTH - OTH array (passed by reference)
  1. ; DGSSN - patient SSN
  1. ; PRELIG - primary eligibility code
  1. ;
  1. ; assumes MSGID,ERRCOUNT to be defined in the calling routine
  1. ;
  1. N DA,DIK
  1. N CNT,IEN33,IEN3301,QFLG,PNDCRTS,Z
  1. S IEN33=+$O(^DGOTH(33,"B",DFN,"")),QFLG=0
  1. I $$GET1^DIQ(8,PRELIG_",",.01)="EXPANDED MH CARE NON-ENROLLEE",'$$CHKTS(IEN33,.DGOTH) D Q
  1. .D ADDERROR^DGENUPL(MSGID,DGSSN,"VISTA HAS THE MOST RECENT OTH-90 DATA",.ERRCOUNT)
  1. .Q
  1. S PNDCRTS=$$GET1^DIQ(33,IEN33_",",.08,"I")
  1. ; pending request
  1. I $G(DGOTH("P"))'="" D
  1. .S Z=$$FILPEND^DGOTHUT1(DFN,"0^^^^^^") I +Z=0 D ADDERROR^DGENUPL(MSGID,DGSSN,$P(Z,U,2),.ERRCOUNT) S QFLG=1 Q
  1. .I $P(DGOTH("P"),U,2)'="@" D
  1. ..S Z=$$FILPEND^DGOTHUT1(DFN,DGOTH("P")) I +Z=0 D ADDERROR^DGENUPL(MSGID,DGSSN,$P(Z,U,2),.ERRCOUNT) S QFLG=1
  1. ..Q
  1. .Q
  1. I QFLG Q
  1. ; re-sort array
  1. D SORTOTH(.DGOTH)
  1. ; denied requests
  1. I $D(DGOTH("D"))>0 D Q:QFLG
  1. .; clear sub-file 33.03
  1. .S DIK="^DGOTH(33,"_IEN33_",3,",DA(1)=IEN33
  1. .S DA=0 F S DA=$O(^DGOTH(33,IEN33,3,DA)) Q:'DA D ^DIK
  1. .K DA
  1. .S CNT="" F S CNT=$O(DGOTH("D",CNT)) Q:'CNT!QFLG D
  1. ..I $P(DGOTH("D",CNT),U)="@" Q ; skip this entry, if it is marked for deletion
  1. ..; if there's a pending request with the same creation timestamp, delete it
  1. ..I PNDCRTS=$P(DGOTH("D",CNT),U,5) D Q:QFLG
  1. ...S Z=$$FILPEND^DGOTHUT1(DFN,"0^^^^^^") I +Z=0 D ADDERROR^DGENUPL(MSGID,DGSSN,$P(Z,U,2),.ERRCOUNT) S QFLG=1
  1. ...Q
  1. ..S Z=$$FILDEN^DGOTHUT1(DFN,DGOTH("D",CNT))
  1. ..I +Z=0 D ADDERROR^DGENUPL(MSGID,DGSSN,$P(Z,U,2),.ERRCOUNT) S QFLG=1 Q
  1. ..Q
  1. .Q
  1. ; approved periods
  1. I $D(DGOTH("A"))>0 D Q:QFLG
  1. .S IEN3301=0 F S IEN3301=$O(^DGOTH(33,IEN33,1,IEN3301)) Q:'IEN3301 D
  1. ..S DIK="^DGOTH(33,"_IEN33_",1,"_IEN3301_",1,",DA(2)=IEN33,DA(1)=IEN3301
  1. ..S DA=0 F S DA=$O(^DGOTH(33,IEN33,1,IEN3301,1,DA)) Q:'DA D ^DIK
  1. ..K DA S DIK="^DGOTH(33,"_IEN33_",1,",DA(1)=IEN33,DA=IEN3301 D ^DIK
  1. ..Q
  1. .S CNT="" F S CNT=$O(DGOTH("A",CNT)) Q:'CNT!QFLG D
  1. ..I $P(DGOTH("A",CNT),U,3)="@" Q ; skip this entry, if it is marked for deletion
  1. ..; if there's a pending request with the same creation timestamp, delete it
  1. ..I PNDCRTS=$P(DGOTH("A",CNT),U,9) D Q:QFLG
  1. ...S Z=$$FILPEND^DGOTHUT1(DFN,"0^^^^^^") I +Z=0 D ADDERROR^DGENUPL(MSGID,DGSSN,$P(Z,U,2),.ERRCOUNT) S QFLG=1
  1. ...Q
  1. ..S Z=$$FILAUTH^DGOTHUT1(DFN,DGOTH("A",CNT))
  1. ..I +Z=0 D ADDERROR^DGENUPL(MSGID,DGSSN,$P(Z,U,2),.ERRCOUNT) S QFLG=1 Q
  1. ..Q
  1. .Q
  1. Q
  1. ;
  1. CHKTS(IEN33,DGOTH) ; check "last edited" timestamps in file 33 DG*5.3*952
  1. ;
  1. ; IEN33 - file 33 ien
  1. ; DGOTH - OTH array (passed by reference)
  1. ;
  1. ; returns 0 if the latest timestamp in file 33 is more recent than the latest timestamp in DGOTH, returns 1 otherwise
  1. ;
  1. N IENS,LASTTS1,LASTTS2,RES,TMPTS,Z,Z1
  1. S RES=1 I $G(IEN33)'>0 G CHKTSX
  1. S (LASTTS1,LASTTS2)=0
  1. ; find the latest timestamp in file 33
  1. S IENS=IEN33_","
  1. S TMPTS=+$$GET1^DIQ(33,IENS,.05,"I") I TMPTS>LASTTS1 S LASTTS1=TMPTS
  1. S Z=0 F S Z=$O(^DGOTH(33,IEN33,1,Z)) Q:'Z D
  1. .S Z1=0 F S Z1=$O(^DGOTH(33,IEN33,1,Z,1,Z1)) Q:'Z1 D
  1. ..S IENS=Z1_","_Z_","_IEN33_","
  1. ..S TMPTS=+$$GET1^DIQ(33.11,IENS,.06,"I") I TMPTS>LASTTS1 S LASTTS1=TMPTS
  1. ..Q
  1. .Q
  1. S Z=0 F S Z=$O(^DGOTH(33,IEN33,3,Z)) Q:'Z D
  1. .S IENS=Z_","_IEN33_","
  1. .S TMPTS=+$$GET1^DIQ(33.03,IENS,.05,"I") I TMPTS>LASTTS1 S LASTTS1=TMPTS
  1. .Q
  1. I LASTTS1=0 G CHKTSX
  1. ; find the latest timestamp in DGOTH array
  1. S TMPTS=+$P($G(DGOTH("P")),U,6) I TMPTS>LASTTS2 S LASTTS2=TMPTS
  1. 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
  1. 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
  1. ; compare timestamps
  1. I LASTTS1>LASTTS2 S RES=0
  1. ;
  1. CHKTSX ; exit point
  1. Q RES
  1. ;
  1. SORTOTH(DGOTH) ; re-sort DGOTH array DG*5.3*952
  1. ;
  1. ; DGOTH - OTH array (passed by reference)
  1. ;
  1. N CNT,TMP,TYPE,VAL,Z,Z1
  1. ; sort approved requests by 365 day period # and 90 day period #
  1. ; sort denied requests by submission date and creation timestamp
  1. F TYPE="A","D" D
  1. .K TMP S CNT="" F S CNT=$O(DGOTH(TYPE,CNT)) Q:'CNT D
  1. ..S VAL=DGOTH(TYPE,CNT),Z=$P(VAL,U),Z1=$P(VAL,U,$S(TYPE="A":2,1:5))
  1. ..I Z'="",Z1'="" S TMP(Z,Z1)=VAL
  1. ..Q
  1. .K DGOTH(TYPE) S CNT=0
  1. .S Z="" F S Z=$O(TMP(Z)) Q:Z="" D
  1. ..S Z1="" F S Z1=$O(TMP(Z,Z1)) Q:Z1="" S CNT=CNT+1,DGOTH(TYPE,CNT)=TMP(Z,Z1)
  1. ..Q
  1. .Q
  1. Q