- 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 Feb 19, 2025@00:07:44 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