DGRP1152U ;ALB/LEG - REGISTRATION SCREEN 11.5.2 (UTILS)/VERIFICATION INFORMATION ;JUN 08, 2020@23:00
;;5.3;Registration;**1014**;AUG 13, 1993;Build 42
;=======================================================================================
; EXTRA PROCESSING FUNCTIONS
Q
;
TMP(DGTMP) ; constructs DGTMP data from Patient CCP data
N DGFIDX,DGEFFDT,DGREC
D CLEAN^VALM10
; DGTMP is NEWd in DGRPU1152A
K DGTMP
M DGTMP(DFN,5)=^DPT(DFN,5)
S DGFIDX=0
F S DGFIDX=$O(DGTMP(DFN,5,DGFIDX)) Q:'DGFIDX S DGREC=$G(DGTMP(DFN,5,DGFIDX,0)) D
. S DGEFFDT=$P(DGREC,U,3)
. S DGTMP("EFDT",DGEFFDT,DGFIDX)=DGREC
D GETCCP
Q
;
GETCCP ; collects all CCP recs; sorts decreasing by EFFDT
N DGBLANKS,DGEFFDT,DGEFFDTO,DGENDT,DGFIDX,DGLINE,DGLINECNT,DGREC,DGRECNO,DGCCPCD,DGRECCCP
N DGRECCCPCD,DGRECCCPNM,DGRECEFDT,DGRECEFDTO,DGRECODT,DGLINEVAR
S VALMCNT=0,DGLINECNT=0,DGLINE=0,DGBLANKS="",$P(DGBLANKS," ",40)=""
;
; BY EFFDT --- DGTMP("EFDT",EFFDT,DGFIDX)=DGREC sort via most recent EFFECTIVE DATE in DECREASING ORDER
S DGEFFDT=""
F S DGEFFDT=$O(DGTMP("EFDT",DGEFFDT),-1) Q:DGEFFDT="" D
. S DGFIDX="" F S DGFIDX=$O(DGTMP("EFDT",DGEFFDT,DGFIDX)) Q:DGFIDX="" D
. . S DGREC=DGTMP("EFDT",DGEFFDT,DGFIDX)
. . S DGENDT=$P(DGREC,U,4)
. . I 'DGENDT D SETREC
;NOTE: for VALM* rtns processing, "VALMCNT" represents total lines written,
S VALMCNT=VALMCNT*2 ; thus, a 2 line display==>"*2", while a 3 line display==>"*3"
Q
SETREC ; sets ListMan Display record
; for Phase I Line 1 data
S DGLINEVAR=""
S DGRECCCPCD=$P(DGREC,U,2)
S DGRECCCPNM=$E($$EXTERNAL^DILFD(2.191,1,"",DGRECCCPCD)_DGBLANKS,1,30)
S DGRECEFDT=$P(DGREC,U,3) S DGRECEFDTO=$$UP^XLFSTR($$FMTE^XLFDT($E(DGRECEFDT,1,12),1))
; strip the space between the day and year
S DGRECODT=$P(DGRECEFDTO," ",1,2)_$P(DGRECEFDTO," ",3)
S VALMCNT=VALMCNT+1
S DGRECNO=$J($E("["_VALMCNT_"] ",1,5),5)
S DGLINEVAR=$$SETFLD^VALM1(DGRECNO,DGLINEVAR,"NO")
S DGLINEVAR=$$SETFLD^VALM1(DGRECCCPNM,DGLINEVAR,"CCPNAME")
S DGLINEVAR=$$SETFLD^VALM1(DGRECODT,DGLINEVAR,"EFFDATE")
S DGLINECNT=DGLINECNT+1
D SET^VALM10(DGLINECNT,DGLINEVAR,VALMCNT)
S DGLINECNT=DGLINECNT+1
S DGLINEVAR="" ; for Phase II Line 2 data space holder
D SET^VALM10(DGLINECNT,DGLINEVAR)
S DGTMP("IDX",VALMCNT,DGFIDX)=DGREC
Q
;
ARCHALL(DFN) ; ARCHIVE CCP entries
; Called from KILL logic of Xref in .361 (PRIMARY ELIGIBILITY) field
; and .01 (ELIGIBILITY CODE) field of the PATIENT ELIGIBILITIES subfile
; when the COLLATERAL OF VET eligibility code is deleted
; Also invoked from Z11 logic when ES is removing the COV eligibility
; For CCPs not already archived:
; - Active CCPs are end dated
; - Achive field set
;
N DGCCP,DGFDA,DGERR,X,Y
S DGCCP=0 F S DGCCP=$O(^DPT(DFN,5,DGCCP)) Q:'DGCCP I $G(^(DGCCP,0))'="" D
. ; Quit if ARCHIVE flag already set
. I $$GET1^DIQ(2.191,DGCCP_","_DFN_",",4,"I")=1 Q
. ; Set the End Date if not already set
. I $$GET1^DIQ(2.191,DGCCP_","_DFN_",",3)="" D SAVENDT^DGRP1152A(DGCCP)
. ; Set the ARCHIVE field to "1"
. S DGFDA(2.191,DGCCP_","_DFN_",",4)=1
. ; CCP LAST UPDATED DATE
. S DGFDA(2.191,DGCCP_","_DFN_",",.01)=$$NOW^XLFDT()
. D FILE^DIE("","DGFDA","DGERR")
Q
;
MULTERR ; Invoked from ^DGRP1152A when adding/editing the Effective Date for a CCP
D EN^DDIOL("Effective Date for this CCP entry must be unique. The Effective Date entered is the same date as a previous entry for a particular CCP.")
;
Q
REMOVE(DFN) ; Invoked from ECDS^DGLOCK1 (Input Transform logic for Primary Eligibility field .361)
; This is called when COLLATERAL OF VET is being replaced
; - Remove all CCPs to a temp global and remove them from the Patient record.
; New X and Y so input transform vars are not overwritten
K ^TMP("DGCCP",$J,DFN)
N DIK,DA,Y,X
S ^TMP("DGCCP",$J,DFN)=""
Q:'$D(^DPT(DFN,5))
; Move everything out and ^DIK the CCPs from the patient file
M ^TMP("DGCCP",$J,DFN,5)=^DPT(DFN,5)
S DA(1)=DFN
S DIK="^DPT("_DFN_",5,"
S DA=0 F S DA=$O(^DPT(DFN,5,DA)) Q:'DA D
.D ^DIK
S ^DPT(DFN,5,0)=""
Q
;
RESTORE(DFN) ; Invoked from "AEL" Cross-reference, Set logic, of Primary Eligibility field .361
; - If the ^TMP("DGCCP",$J,DFN) global (see REMOVE tag) does not exist, then quit.
; - Otherwise, move the CCPs in ^TMP back into the patient record.
; and if COV is no longer in .361 field, add it into the PATIENT ELIGIBILIITIES subfile .0361
; The result is that COV is moved from PRIMARY to the subfile and the CCPs are intact
; (COV cannnot be deleted if there are active CCPs but it can be replaced with another eligibility and moved to the subfile.)
; NEW X and Y so xref vars aren't overwritten
N DGZ,Y,X,DGERR,DGIENS,DGFDA,DGDATA,DGFDAIEN,DGNEWIEN
I '$D(^TMP("DGCCP",$J,DFN)) Q
S DGZ=0 F S DGZ=$O(^TMP("DGCCP",$J,DFN,5,DGZ)) Q:'DGZ D
. S DGERR=0
. S DGIENS=DFN_","
. S DGIENS="+1,"_DGIENS
. S DGFDA(2.191,DGIENS,.01)=$P(^TMP("DGCCP",$J,DFN,5,DGZ,0),"^",1)
. S DGFDA(2.191,DGIENS,1)=$P(^TMP("DGCCP",$J,DFN,5,DGZ,0),"^",2)
. S DGFDA(2.191,DGIENS,2)=$P(^TMP("DGCCP",$J,DFN,5,DGZ,0),"^",3)
. S DGFDA(2.191,DGIENS,3)=$P(^TMP("DGCCP",$J,DFN,5,DGZ,0),"^",4)
. S DGFDA(2.191,DGIENS,4)=$P(^TMP("DGCCP",$J,DFN,5,DGZ,0),"^",5)
. D UPDATE^DIE("","DGFDA","","DGERR")
. K DGFDA
K ^TMP("DGCCP",$J,DFN)
; If COV is still in .361, nothing changed, quit
I $$GET1^DIQ(2,DFN_",",.361,"E")="COLLATERAL OF VET." Q
;
; Otherwise, COV has been replaced with another eligibility - restore COV into the Eligibilities subfile .0361
N DGDATA,DGFDAIEN,DGNEWIEN
S DGNEWIEN="+1,"_DFN_","
S DGDATA(2.0361,DGNEWIEN,.01)=$$FIND1^DIC(8,"","B","COLLATERAL")
S DGFDAIEN(1)=$$FIND1^DIC(8,"","B","COLLATERAL")
D UPDATE^DIE("","DGDATA","DGFDAIEN","DGERR")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRP1152U 5812 printed Dec 13, 2024@02:55:30 Page 2
DGRP1152U ;ALB/LEG - REGISTRATION SCREEN 11.5.2 (UTILS)/VERIFICATION INFORMATION ;JUN 08, 2020@23:00
+1 ;;5.3;Registration;**1014**;AUG 13, 1993;Build 42
+2 ;=======================================================================================
+3 ; EXTRA PROCESSING FUNCTIONS
+4 QUIT
+5 ;
TMP(DGTMP) ; constructs DGTMP data from Patient CCP data
+1 NEW DGFIDX,DGEFFDT,DGREC
+2 DO CLEAN^VALM10
+3 ; DGTMP is NEWd in DGRPU1152A
+4 KILL DGTMP
+5 MERGE DGTMP(DFN,5)=^DPT(DFN,5)
+6 SET DGFIDX=0
+7 FOR
SET DGFIDX=$ORDER(DGTMP(DFN,5,DGFIDX))
if 'DGFIDX
QUIT
SET DGREC=$GET(DGTMP(DFN,5,DGFIDX,0))
Begin DoDot:1
+8 SET DGEFFDT=$PIECE(DGREC,U,3)
+9 SET DGTMP("EFDT",DGEFFDT,DGFIDX)=DGREC
End DoDot:1
+10 DO GETCCP
+11 QUIT
+12 ;
GETCCP ; collects all CCP recs; sorts decreasing by EFFDT
+1 NEW DGBLANKS,DGEFFDT,DGEFFDTO,DGENDT,DGFIDX,DGLINE,DGLINECNT,DGREC,DGRECNO,DGCCPCD,DGRECCCP
+2 NEW DGRECCCPCD,DGRECCCPNM,DGRECEFDT,DGRECEFDTO,DGRECODT,DGLINEVAR
+3 SET VALMCNT=0
SET DGLINECNT=0
SET DGLINE=0
SET DGBLANKS=""
SET $PIECE(DGBLANKS," ",40)=""
+4 ;
+5 ; BY EFFDT --- DGTMP("EFDT",EFFDT,DGFIDX)=DGREC sort via most recent EFFECTIVE DATE in DECREASING ORDER
+6 SET DGEFFDT=""
+7 FOR
SET DGEFFDT=$ORDER(DGTMP("EFDT",DGEFFDT),-1)
if DGEFFDT=""
QUIT
Begin DoDot:1
+8 SET DGFIDX=""
FOR
SET DGFIDX=$ORDER(DGTMP("EFDT",DGEFFDT,DGFIDX))
if DGFIDX=""
QUIT
Begin DoDot:2
+9 SET DGREC=DGTMP("EFDT",DGEFFDT,DGFIDX)
+10 SET DGENDT=$PIECE(DGREC,U,4)
+11 IF 'DGENDT
DO SETREC
End DoDot:2
End DoDot:1
+12 ;NOTE: for VALM* rtns processing, "VALMCNT" represents total lines written,
+13 ; thus, a 2 line display==>"*2", while a 3 line display==>"*3"
SET VALMCNT=VALMCNT*2
+14 QUIT
SETREC ; sets ListMan Display record
+1 ; for Phase I Line 1 data
+2 SET DGLINEVAR=""
+3 SET DGRECCCPCD=$PIECE(DGREC,U,2)
+4 SET DGRECCCPNM=$EXTRACT($$EXTERNAL^DILFD(2.191,1,"",DGRECCCPCD)_DGBLANKS,1,30)
+5 SET DGRECEFDT=$PIECE(DGREC,U,3)
SET DGRECEFDTO=$$UP^XLFSTR($$FMTE^XLFDT($EXTRACT(DGRECEFDT,1,12),1))
+6 ; strip the space between the day and year
+7 SET DGRECODT=$PIECE(DGRECEFDTO," ",1,2)_$PIECE(DGRECEFDTO," ",3)
+8 SET VALMCNT=VALMCNT+1
+9 SET DGRECNO=$JUSTIFY($EXTRACT("["_VALMCNT_"] ",1,5),5)
+10 SET DGLINEVAR=$$SETFLD^VALM1(DGRECNO,DGLINEVAR,"NO")
+11 SET DGLINEVAR=$$SETFLD^VALM1(DGRECCCPNM,DGLINEVAR,"CCPNAME")
+12 SET DGLINEVAR=$$SETFLD^VALM1(DGRECODT,DGLINEVAR,"EFFDATE")
+13 SET DGLINECNT=DGLINECNT+1
+14 DO SET^VALM10(DGLINECNT,DGLINEVAR,VALMCNT)
+15 SET DGLINECNT=DGLINECNT+1
+16 ; for Phase II Line 2 data space holder
SET DGLINEVAR=""
+17 DO SET^VALM10(DGLINECNT,DGLINEVAR)
+18 SET DGTMP("IDX",VALMCNT,DGFIDX)=DGREC
+19 QUIT
+20 ;
ARCHALL(DFN) ; ARCHIVE CCP entries
+1 ; Called from KILL logic of Xref in .361 (PRIMARY ELIGIBILITY) field
+2 ; and .01 (ELIGIBILITY CODE) field of the PATIENT ELIGIBILITIES subfile
+3 ; when the COLLATERAL OF VET eligibility code is deleted
+4 ; Also invoked from Z11 logic when ES is removing the COV eligibility
+5 ; For CCPs not already archived:
+6 ; - Active CCPs are end dated
+7 ; - Achive field set
+8 ;
+9 NEW DGCCP,DGFDA,DGERR,X,Y
+10 SET DGCCP=0
FOR
SET DGCCP=$ORDER(^DPT(DFN,5,DGCCP))
if 'DGCCP
QUIT
IF $GET(^(DGCCP,0))'=""
Begin DoDot:1
+11 ; Quit if ARCHIVE flag already set
+12 IF $$GET1^DIQ(2.191,DGCCP_","_DFN_",",4,"I")=1
QUIT
+13 ; Set the End Date if not already set
+14 IF $$GET1^DIQ(2.191,DGCCP_","_DFN_",",3)=""
DO SAVENDT^DGRP1152A(DGCCP)
+15 ; Set the ARCHIVE field to "1"
+16 SET DGFDA(2.191,DGCCP_","_DFN_",",4)=1
+17 ; CCP LAST UPDATED DATE
+18 SET DGFDA(2.191,DGCCP_","_DFN_",",.01)=$$NOW^XLFDT()
+19 DO FILE^DIE("","DGFDA","DGERR")
End DoDot:1
+20 QUIT
+21 ;
MULTERR ; Invoked from ^DGRP1152A when adding/editing the Effective Date for a CCP
+1 DO EN^DDIOL("Effective Date for this CCP entry must be unique. The Effective Date entered is the same date as a previous entry for a particular CCP.")
+2 ;
+3 QUIT
REMOVE(DFN) ; Invoked from ECDS^DGLOCK1 (Input Transform logic for Primary Eligibility field .361)
+1 ; This is called when COLLATERAL OF VET is being replaced
+2 ; - Remove all CCPs to a temp global and remove them from the Patient record.
+3 ; New X and Y so input transform vars are not overwritten
+4 KILL ^TMP("DGCCP",$JOB,DFN)
+5 NEW DIK,DA,Y,X
+6 SET ^TMP("DGCCP",$JOB,DFN)=""
+7 if '$DATA(^DPT(DFN,5))
QUIT
+8 ; Move everything out and ^DIK the CCPs from the patient file
+9 MERGE ^TMP("DGCCP",$JOB,DFN,5)=^DPT(DFN,5)
+10 SET DA(1)=DFN
+11 SET DIK="^DPT("_DFN_",5,"
+12 SET DA=0
FOR
SET DA=$ORDER(^DPT(DFN,5,DA))
if 'DA
QUIT
Begin DoDot:1
+13 DO ^DIK
End DoDot:1
+14 SET ^DPT(DFN,5,0)=""
+15 QUIT
+16 ;
RESTORE(DFN) ; Invoked from "AEL" Cross-reference, Set logic, of Primary Eligibility field .361
+1 ; - If the ^TMP("DGCCP",$J,DFN) global (see REMOVE tag) does not exist, then quit.
+2 ; - Otherwise, move the CCPs in ^TMP back into the patient record.
+3 ; and if COV is no longer in .361 field, add it into the PATIENT ELIGIBILIITIES subfile .0361
+4 ; The result is that COV is moved from PRIMARY to the subfile and the CCPs are intact
+5 ; (COV cannnot be deleted if there are active CCPs but it can be replaced with another eligibility and moved to the subfile.)
+6 ; NEW X and Y so xref vars aren't overwritten
+7 NEW DGZ,Y,X,DGERR,DGIENS,DGFDA,DGDATA,DGFDAIEN,DGNEWIEN
+8 IF '$DATA(^TMP("DGCCP",$JOB,DFN))
QUIT
+9 SET DGZ=0
FOR
SET DGZ=$ORDER(^TMP("DGCCP",$JOB,DFN,5,DGZ))
if 'DGZ
QUIT
Begin DoDot:1
+10 SET DGERR=0
+11 SET DGIENS=DFN_","
+12 SET DGIENS="+1,"_DGIENS
+13 SET DGFDA(2.191,DGIENS,.01)=$PIECE(^TMP("DGCCP",$JOB,DFN,5,DGZ,0),"^",1)
+14 SET DGFDA(2.191,DGIENS,1)=$PIECE(^TMP("DGCCP",$JOB,DFN,5,DGZ,0),"^",2)
+15 SET DGFDA(2.191,DGIENS,2)=$PIECE(^TMP("DGCCP",$JOB,DFN,5,DGZ,0),"^",3)
+16 SET DGFDA(2.191,DGIENS,3)=$PIECE(^TMP("DGCCP",$JOB,DFN,5,DGZ,0),"^",4)
+17 SET DGFDA(2.191,DGIENS,4)=$PIECE(^TMP("DGCCP",$JOB,DFN,5,DGZ,0),"^",5)
+18 DO UPDATE^DIE("","DGFDA","","DGERR")
+19 KILL DGFDA
End DoDot:1
+20 KILL ^TMP("DGCCP",$JOB,DFN)
+21 ; If COV is still in .361, nothing changed, quit
+22 IF $$GET1^DIQ(2,DFN_",",.361,"E")="COLLATERAL OF VET."
QUIT
+23 ;
+24 ; Otherwise, COV has been replaced with another eligibility - restore COV into the Eligibilities subfile .0361
+25 NEW DGDATA,DGFDAIEN,DGNEWIEN
+26 SET DGNEWIEN="+1,"_DFN_","
+27 SET DGDATA(2.0361,DGNEWIEN,.01)=$$FIND1^DIC(8,"","B","COLLATERAL")
+28 SET DGFDAIEN(1)=$$FIND1^DIC(8,"","B","COLLATERAL")
+29 DO UPDATE^DIE("","DGDATA","DGFDAIEN","DGERR")
+30 QUIT
