DGCOMPACTELIG ;ALB/BPA,CMC - Routine for COMPACT Act Eligibility;04/29/2024@11:30AM
;;5.3;Registration;**1104**;Aug 13, 1993;Build 59
; *1104* API for COMPACT Act Administrative Eligibility
; Reference to FILEMANERR^PXCOMPACT1 in ICR #7469
;
Q
ELIG(DFN,RTN) ;
;DFN - Internal Patient ID *(required)
;RTN - original calling routine (required)
N DA,DGXTMPDTTM,ELIG,NOW,VACOM,XTMPSUB
I $G(RTN)="" S RTN="NO ROUTINE"
S DGXTMPDTTM="",NOW=$$NOW^XLFDT,ELIG="UNDETERMINED",XTMPSUB="DGCOMPACTELIG"_DT
;Determine and return admin eligibility (ELIGIBLE, NOT ELIGIBLE or UNDETERMINED)
D CAI^VADPT
I VACOM("CAI")=1 S ELIG="ELIGIBLE" Q ELIG
D CHECKCACHE(DFN,NOW,XTMPSUB)
I '$D(^XTMP("DGELIG",XTMPSUB,DFN)) S ELIG=$$WEBSRVC(DFN,$G(RTN))
E D
. S DGXTMPDTTM=$O(^XTMP("DGELIG",XTMPSUB,DFN,DGXTMPDTTM))
. S ELIG=$$CHECKDFN(DFN,XTMPSUB,$G(RTN),NOW,DGXTMPDTTM)
Q ELIG
;
CHECKCACHE(DFN,NOW,XTMPSUB) ;
N DGELIGDTTM,PURGDT,XTMPDT
; Look for expired cache to clean it up, use $O and removed them
S XTMPDT=""
F S XTMPDT=$O(^XTMP("DGELIG",XTMPDT)) Q:(XTMPDT="") D
. S PURGDT=$P(^XTMP("DGELIG",XTMPDT,0),"^",1)
. I $P(NOW,".")>$P(PURGDT,".") K ^XTMP("DGELIG",XTMPDT)
I '$D(^XTMP("DGELIG",XTMPSUB)) D
. S PURGDT=DT_".1159"
. S ^XTMP("DGELIG",XTMPSUB,0)=PURGDT_U_DT_U_"COMPACT Act administrative eligibility"
Q
;
CHECKDFN(DFN,XTMPSUB,RTN,NOW,DTTM) ;
;If the current time is more than two hours (7200 seconds) past the last stored eligibility,
;kill the stored value and check for changes
I $$FMDIFF^XLFDT(NOW,DTTM,2)>7200 D
. K ^XTMP("DGELIG",XTMPSUB,DFN,DTTM)
. S ELIG=$$WEBSRVC(DFN,RTN)
E S ELIG=$P(^XTMP("DGELIG",XTMPSUB,DFN,DTTM),U,1)
Q ELIG
;
WEBSRVC(DFN,DGRTN) ;
N DGCOMP,DGKEY,DGREQNAME,DGREQDTTM,DGRESP,DGRESPDTTM,ELIG,PURGDT,PURGSEQ,VAEL
S (DGCOMP,DGKEY,DGREQNAME,DGREQDTTM,DGRESP,DGRESPDTTM,PURGDT,PURGSEQ)="",ELIG="UNDETERMINED"
S DGKEY=$$GETICN^MPIF001(DFN),DGREQNAME="VistADataVTwo"
I $P(DGKEY,"^",1)'=-1 D
. S DGREQDTTM=$$NOW^XLFDT
. S DGRESP=$$EN^DGREGEEWS(DGKEY,DGREQNAME,"","",.DGCOMP)
. S DGRESPDTTM=$$NOW^XLFDT
;
I $P(DGRESP,"^",1)=1 D
. I DGCOMP="No" S ELIG="NOT ELIGIBLE"
. I DGCOMP="Yes" S ELIG="ELIGIBLE"
;
S ^XTMP("DGELIG",XTMPSUB,DFN,$$NOW^XLFDT)=ELIG_"^"_DFN_"^"_$G(DGRTN)
;Processing for Transaction Log here
I $P(DGKEY,"^",1)'=-1 D
. S DGRESP=$TR(DGRESP,"^","~")
. N CMPMSG,DGIEN,TRDATA
. S DGIEN="+1,"
. S TRDATA(33.3,DGIEN,.01)=DGKEY
. S TRDATA(33.3,DGIEN,2)=DGRTN
. S TRDATA(33.3,DGIEN,3)=DGREQDTTM
. S TRDATA(33.3,DGIEN,4)=DGRESP
. S TRDATA(33.3,DGIEN,5)=DGRESPDTTM
. D UPDATE^DIE("","TRDATA","","CMPMSG")
. I $D(CMPMSG("DIERR")) D FILEMANERR^PXCOMPACT1(DFN,.TRDATA,.CMPMSG)
;
S PURGDT=$O(^DGCOMP(33.3,"C","")) I $$FMDIFF^XLFDT(DT,PURGDT,1)>29 D
. F S PURGSEQ=$O(^DGCOMP(33.3,"C",PURGDT,PURGSEQ)) Q:PURGSEQ="" D
. . ;Loop through the "C" level to purge data
. . S DIK="^DGCOMP(33.3,"
. . S DA=PURGSEQ
. . D ^DIK
. . K DA,DIK
;
Q ELIG
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGCOMPACTELIG 2997 printed Sep 23, 2025@20:17:33 Page 2
DGCOMPACTELIG ;ALB/BPA,CMC - Routine for COMPACT Act Eligibility;04/29/2024@11:30AM
+1 ;;5.3;Registration;**1104**;Aug 13, 1993;Build 59
+2 ; *1104* API for COMPACT Act Administrative Eligibility
+3 ; Reference to FILEMANERR^PXCOMPACT1 in ICR #7469
+4 ;
+5 QUIT
ELIG(DFN,RTN) ;
+1 ;DFN - Internal Patient ID *(required)
+2 ;RTN - original calling routine (required)
+3 NEW DA,DGXTMPDTTM,ELIG,NOW,VACOM,XTMPSUB
+4 IF $GET(RTN)=""
SET RTN="NO ROUTINE"
+5 SET DGXTMPDTTM=""
SET NOW=$$NOW^XLFDT
SET ELIG="UNDETERMINED"
SET XTMPSUB="DGCOMPACTELIG"_DT
+6 ;Determine and return admin eligibility (ELIGIBLE, NOT ELIGIBLE or UNDETERMINED)
+7 DO CAI^VADPT
+8 IF VACOM("CAI")=1
SET ELIG="ELIGIBLE"
QUIT ELIG
+9 DO CHECKCACHE(DFN,NOW,XTMPSUB)
+10 IF '$DATA(^XTMP("DGELIG",XTMPSUB,DFN))
SET ELIG=$$WEBSRVC(DFN,$GET(RTN))
+11 IF '$TEST
Begin DoDot:1
+12 SET DGXTMPDTTM=$ORDER(^XTMP("DGELIG",XTMPSUB,DFN,DGXTMPDTTM))
+13 SET ELIG=$$CHECKDFN(DFN,XTMPSUB,$GET(RTN),NOW,DGXTMPDTTM)
End DoDot:1
+14 QUIT ELIG
+15 ;
CHECKCACHE(DFN,NOW,XTMPSUB) ;
+1 NEW DGELIGDTTM,PURGDT,XTMPDT
+2 ; Look for expired cache to clean it up, use $O and removed them
+3 SET XTMPDT=""
+4 FOR
SET XTMPDT=$ORDER(^XTMP("DGELIG",XTMPDT))
if (XTMPDT="")
QUIT
Begin DoDot:1
+5 SET PURGDT=$PIECE(^XTMP("DGELIG",XTMPDT,0),"^",1)
+6 IF $PIECE(NOW,".")>$PIECE(PURGDT,".")
KILL ^XTMP("DGELIG",XTMPDT)
End DoDot:1
+7 IF '$DATA(^XTMP("DGELIG",XTMPSUB))
Begin DoDot:1
+8 SET PURGDT=DT_".1159"
+9 SET ^XTMP("DGELIG",XTMPSUB,0)=PURGDT_U_DT_U_"COMPACT Act administrative eligibility"
End DoDot:1
+10 QUIT
+11 ;
CHECKDFN(DFN,XTMPSUB,RTN,NOW,DTTM) ;
+1 ;If the current time is more than two hours (7200 seconds) past the last stored eligibility,
+2 ;kill the stored value and check for changes
+3 IF $$FMDIFF^XLFDT(NOW,DTTM,2)>7200
Begin DoDot:1
+4 KILL ^XTMP("DGELIG",XTMPSUB,DFN,DTTM)
+5 SET ELIG=$$WEBSRVC(DFN,RTN)
End DoDot:1
+6 IF '$TEST
SET ELIG=$PIECE(^XTMP("DGELIG",XTMPSUB,DFN,DTTM),U,1)
+7 QUIT ELIG
+8 ;
WEBSRVC(DFN,DGRTN) ;
+1 NEW DGCOMP,DGKEY,DGREQNAME,DGREQDTTM,DGRESP,DGRESPDTTM,ELIG,PURGDT,PURGSEQ,VAEL
+2 SET (DGCOMP,DGKEY,DGREQNAME,DGREQDTTM,DGRESP,DGRESPDTTM,PURGDT,PURGSEQ)=""
SET ELIG="UNDETERMINED"
+3 SET DGKEY=$$GETICN^MPIF001(DFN)
SET DGREQNAME="VistADataVTwo"
+4 IF $PIECE(DGKEY,"^",1)'=-1
Begin DoDot:1
+5 SET DGREQDTTM=$$NOW^XLFDT
+6 SET DGRESP=$$EN^DGREGEEWS(DGKEY,DGREQNAME,"","",.DGCOMP)
+7 SET DGRESPDTTM=$$NOW^XLFDT
End DoDot:1
+8 ;
+9 IF $PIECE(DGRESP,"^",1)=1
Begin DoDot:1
+10 IF DGCOMP="No"
SET ELIG="NOT ELIGIBLE"
+11 IF DGCOMP="Yes"
SET ELIG="ELIGIBLE"
End DoDot:1
+12 ;
+13 SET ^XTMP("DGELIG",XTMPSUB,DFN,$$NOW^XLFDT)=ELIG_"^"_DFN_"^"_$G(DGRTN)
+14 ;Processing for Transaction Log here
+15 IF $PIECE(DGKEY,"^",1)'=-1
Begin DoDot:1
+16 SET DGRESP=$TRANSLATE(DGRESP,"^","~")
+17 NEW CMPMSG,DGIEN,TRDATA
+18 SET DGIEN="+1,"
+19 SET TRDATA(33.3,DGIEN,.01)=DGKEY
+20 SET TRDATA(33.3,DGIEN,2)=DGRTN
+21 SET TRDATA(33.3,DGIEN,3)=DGREQDTTM
+22 SET TRDATA(33.3,DGIEN,4)=DGRESP
+23 SET TRDATA(33.3,DGIEN,5)=DGRESPDTTM
+24 DO UPDATE^DIE("","TRDATA","","CMPMSG")
+25 IF $DATA(CMPMSG("DIERR"))
DO FILEMANERR^PXCOMPACT1(DFN,.TRDATA,.CMPMSG)
End DoDot:1
+26 ;
+27 SET PURGDT=$ORDER(^DGCOMP(33.3,"C",""))
IF $$FMDIFF^XLFDT(DT,PURGDT,1)>29
Begin DoDot:1
+28 FOR
SET PURGSEQ=$ORDER(^DGCOMP(33.3,"C",PURGDT,PURGSEQ))
if PURGSEQ=""
QUIT
Begin DoDot:2
+29 ;Loop through the "C" level to purge data
+30 SET DIK="^DGCOMP(33.3,"
+31 SET DA=PURGSEQ
+32 DO ^DIK
+33 KILL DA,DIK
End DoDot:2
End DoDot:1
+34 ;
+35 QUIT ELIG
