DGRRLU1A ;alb/aas,BPFO/MM DG Replacement and Rehosting RPC for VADPT (cont) - ;11/12/2003
;;5.3;Registration;**538**;Aug 13, 1993
;
;Continued from DGRRLU1
;
10 ; -- means test required, get current means test status and MAS Parameter display of notification
; if (paramater && last means test indicator == "r") display message
N DGMTLST,DIVRULE,DIVTXT,DGMSGF,DGMFLG,X,DGDOM,DGDOM1
S DIVRULE="false"
I $P($G(^DG(40.8,+$O(^DG(40.8,"AD",+$G(DIV),0)),"MT")),"^")="Y" S DIVRULE="true"
S DGMSGF=1
S DGMTLST=$$CMTS^DGMTU(DFN)
S DGMFLG=$$MFLG^DGMTU(DGMTLST)
;S DGMTDATE=$P($G(^DGMT(408.31,+DGMTLST,0)),U)
S DIVTXT=$P($G(^DG(40.8,+$O(^DG(40.8,"AD",+$G(DIV),0)),"MT")),"^",2)
S X=" <businessRule alertId='meansTestRequired' lastMeansTestDate='"_$$CHARCHK^DGRRUTL($P(DGMTLST,"^",2))
S X=X_"' lastMeansTestIndicator='"_$$CHARCHK^DGRRUTL($P(DGMTLST,"^",3))_"' masDivisionRule='"_$$CHARCHK^DGRRUTL(DIVRULE)_"' text='"_$$CHARCHK^DGRRUTL(DIVTXT)
S X=X_"' addTxt='"_$$CHARCHK^DGRRUTL(DGMFLG)_"'></businessRule>"
DO ADD^DGRRLU(X)
;
11 ; -- legacy data for patient, check to see if patient on M data base merged into current M database
; Beginning with release 4, the legacy alert will always return false.
; Alert no longer displayed. It will be removed in a future release.
DO ADD^DGRRLU(" <businessRule alertId='legacyDataExists' checkValue='"_$$CHARCHK^DGRRUTL("false")_"' facility=''></businessRule>")
;
12 ; -- fugitive felon -- to be released soon.
NEW FUGITIVE
SET FUGITIVE="false"
IF $D(^DPT("AXFFP",1,DFN)) SET FUGITIVE="true"
DO ADD^DGRRLU(" <businessRule alertId='fugitiveFelon' fugitiveStatus='"_$$CHARCHK^DGRRUTL(FUGITIVE)_"'></businessRule>")
;
13 ; -- patient record flag
N DGPFFLGS,DGPFFLG,DGRRNFLG
S DGRRNFLG=0
S DGPFFLG=""
IF +$G(PARAMS("PATIENT_RECORD_FLAG")) DO ; old version of patient record flag
.I $L($T(GETACT^DGPFAPI)) S DGPFFLGS=$$GETACT^DGPFAPI(DFN,"DGPFFLGS") D
.. I $G(DGPFFLGS)=0 Q
.. N DGPFI
.. S DGPFI=0
.. F S DGPFI=$O(DGPFFLGS(DGPFI)) Q:'DGPFI D
...I DGPFI>1 S DGPFFLG=DGPFFLG_", "
...S DGPFFLG=DGPFFLG_$P($G(DGPFFLGS(+DGPFI,"FLAG")),U,2)
.DO ADD^DGRRLU(" <businessRule alertId='patientRecordFlag' flag='"_$$CHARCHK^DGRRUTL(DGPFFLG)_"'></businessRule>")
;
IF '+$G(PARAMS("PATIENT_RECORD_FLAG")) DO ; new (06/17/04) version of patient record flag can be turned on with this param, the flag and the old code can be removed once the new stuff is approved
.I '$L($T(GETACT^DGPFAPI)) S DGRRNFLG=1 D NOALRT
.Q:DGRRNFLG=1
.S DGPFFLGS=$$GETACT^DGPFAPI(DFN,"DGPFFLGS") D
.. I $G(DGPFFLGS)=0 D NOALRT Q
.. D ADD^DGRRLU(" <businessRule alertId='patientRecordFlag'>")
.. N DGPFI
.. S DGPFI=0
.. F S DGPFI=$O(DGPFFLGS(DGPFI)) Q:'DGPFI D
...N APPRVBY,ASSIGNDT,CATEGORY,FLAG,FLAGTYPE,ORIGSITE,OWNER,REVDT,LINE
...S APPRVBY=$$CHARCHK^DGRRUTL($P($G(DGPFFLGS(DGPFI,"APPRVBY")),U,2))
...S ASSIGNDT=$P($P($G(DGPFFLGS(DGPFI,"ASSIGNDT")),U),".")
...S FLAG=$$CHARCHK^DGRRUTL($P($G(DGPFFLGS(DGPFI,"FLAG")),U,2))
...S FLAGTYPE=$$CHARCHK^DGRRUTL($P($G(DGPFFLGS(DGPFI,"FLAGTYPE")),U,2))
...S ORIGSITE=$$CHARCHK^DGRRUTL($P($G(DGPFFLGS(DGPFI,"ORIGSITE")),U,2))
...S OWNER=$$CHARCHK^DGRRUTL($P($G(DGPFFLGS(DGPFI,"OWNER")),U,2))
...S REVDT=$P($G(DGPFFLGS(DGPFI,"REVIEWDT")),U)
...S LINE=" <flag flagNumber='"_DGPFI_"' flag='"_FLAG_"' category='"_FLAGTYPE_"' type='"_FLAGTYPE_"' assigndt='"_ASSIGNDT_"' apprvBy='"_APPRVBY_"' revDate='"_REVDT
...S LINE=LINE_"' ownerSite='"_OWNER_"' origSite='"_ORIGSITE_"'>"
...D ADD^DGRRLU(LINE)
...D ADD^DGRRLU(" <narrations>")
...N DGRRNI
...S DGRRNI=0
...F S DGRRNI=$O(DGPFFLGS(DGPFI,"NARR",DGRRNI)) Q:'DGRRNI D
....N DGRRNL
....S DGRRNL=$G(DGPFFLGS(DGPFI,"NARR",DGRRNI,0))
....D ADD^DGRRLU(" <narration>"_$$CHARCHK^DGRRUTL(DGRRNL)_"</narration>")
...D ADD^DGRRLU(" </narrations>")
...D ADD^DGRRLU(" </flag>")
..D ADD^DGRRLU(" </businessRule>")
;
14 ; -- patient merged -- not a requirement
DO ADD^DGRRLU(" <businessRule alertId='mergedPatient' recordMergedTo='"_$$CHARCHK^DGRRUTL($P($G(^DPT(DFN,0)),"^",19))_"'></businessRule>")
;
15 ; -- combat vet status -- being worked on by Edna Curtain.
N CVSTATUS,CVEND,DGCV
SET (CVSTATUS,CVEND,DGCV)=""
I $L($T(CVEDT^DGCV)) S DGCV=$$CVEDT^DGCV(+DFN)
I $P(DGCV,"^")=1 D
. SET CVSTATUS=$S($P(DGCV,"^",2)>DT:"ELIGIBLE",1:"EXPIRED")
. SET CVEND=$P(DGCV,"^",2)
DO ADD^DGRRLU(" <businessRule alertId='combatvet' status='"_$$CHARCHK^DGRRUTL($G(CVSTATUS))_"' endDate='"_$$CHARCHK^DGRRUTL($G(CVEND))_"'></businessRule>")
16 ;Bad Address Indicator
N DGRRBA
S DGRRBA=$$BADADR^DGUTL3(DFN)
DO ADD^DGRRLU(" <businessRule alertId='badAddress' indicator='"_$$CHARCHK^DGRRUTL($G(DGRRBA))_"'></businessRule>")
;
END QUIT
;
NOALRT ;Returns an empty alert for Patient Record Flag
D ADD^DGRRLU(" <businessRule alertId='patientRecordFlag'>")
S LINE=" <flag flagNumber='' category='' type='' assigndt='' apprvBy='' revDate='' ownerSite='' origSite=''>"
D ADD^DGRRLU(LINE)
D ADD^DGRRLU(" <narrations></narrations>")
D ADD^DGRRLU(" </flag>")
D ADD^DGRRLU(" </businessRule>")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRRLU1A 5144 printed Sep 23, 2025@20:33:29 Page 2
DGRRLU1A ;alb/aas,BPFO/MM DG Replacement and Rehosting RPC for VADPT (cont) - ;11/12/2003
+1 ;;5.3;Registration;**538**;Aug 13, 1993
+2 ;
+3 ;Continued from DGRRLU1
+4 ;
10 ; -- means test required, get current means test status and MAS Parameter display of notification
+1 ; if (paramater && last means test indicator == "r") display message
+2 NEW DGMTLST,DIVRULE,DIVTXT,DGMSGF,DGMFLG,X,DGDOM,DGDOM1
+3 SET DIVRULE="false"
+4 IF $PIECE($GET(^DG(40.8,+$ORDER(^DG(40.8,"AD",+$GET(DIV),0)),"MT")),"^")="Y"
SET DIVRULE="true"
+5 SET DGMSGF=1
+6 SET DGMTLST=$$CMTS^DGMTU(DFN)
+7 SET DGMFLG=$$MFLG^DGMTU(DGMTLST)
+8 ;S DGMTDATE=$P($G(^DGMT(408.31,+DGMTLST,0)),U)
+9 SET DIVTXT=$PIECE($GET(^DG(40.8,+$ORDER(^DG(40.8,"AD",+$GET(DIV),0)),"MT")),"^",2)
+10 SET X=" <businessRule alertId='meansTestRequired' lastMeansTestDate='"_$$CHARCHK^DGRRUTL($PIECE(DGMTLST,"^",2))
+11 SET X=X_"' lastMeansTestIndicator='"_$$CHARCHK^DGRRUTL($PIECE(DGMTLST,"^",3))_"' masDivisionRule='"_$$CHARCHK^DGRRUTL(DIVRULE)_"' text='"_$$CHARCHK^DGRRUTL(DIVTXT)
+12 SET X=X_"' addTxt='"_$$CHARCHK^DGRRUTL(DGMFLG)_"'></businessRule>"
+13 DO ADD^DGRRLU(X)
+14 ;
11 ; -- legacy data for patient, check to see if patient on M data base merged into current M database
+1 ; Beginning with release 4, the legacy alert will always return false.
+2 ; Alert no longer displayed. It will be removed in a future release.
+3 DO ADD^DGRRLU(" <businessRule alertId='legacyDataExists' checkValue='"_$$CHARCHK^DGRRUTL("false")_"' facility=''></businessRule>")
+4 ;
12 ; -- fugitive felon -- to be released soon.
+1 NEW FUGITIVE
+2 SET FUGITIVE="false"
+3 IF $DATA(^DPT("AXFFP",1,DFN))
SET FUGITIVE="true"
+4 DO ADD^DGRRLU(" <businessRule alertId='fugitiveFelon' fugitiveStatus='"_$$CHARCHK^DGRRUTL(FUGITIVE)_"'></businessRule>")
+5 ;
13 ; -- patient record flag
+1 NEW DGPFFLGS,DGPFFLG,DGRRNFLG
+2 SET DGRRNFLG=0
+3 SET DGPFFLG=""
+4 ; old version of patient record flag
IF +$GET(PARAMS("PATIENT_RECORD_FLAG"))
Begin DoDot:1
+5 IF $LENGTH($TEXT(GETACT^DGPFAPI))
SET DGPFFLGS=$$GETACT^DGPFAPI(DFN,"DGPFFLGS")
Begin DoDot:2
+6 IF $GET(DGPFFLGS)=0
QUIT
+7 NEW DGPFI
+8 SET DGPFI=0
+9 FOR
SET DGPFI=$ORDER(DGPFFLGS(DGPFI))
if 'DGPFI
QUIT
Begin DoDot:3
+10 IF DGPFI>1
SET DGPFFLG=DGPFFLG_", "
+11 SET DGPFFLG=DGPFFLG_$PIECE($GET(DGPFFLGS(+DGPFI,"FLAG")),U,2)
End DoDot:3
End DoDot:2
+12 DO ADD^DGRRLU(" <businessRule alertId='patientRecordFlag' flag='"_$$CHARCHK^DGRRUTL(DGPFFLG)_"'></businessRule>")
End DoDot:1
+13 ;
+14 ; new (06/17/04) version of patient record flag can be turned on with this param, the flag and the old code can be removed once the new stuff is approved
IF '+$GET(PARAMS("PATIENT_RECORD_FLAG"))
Begin DoDot:1
+15 IF '$LENGTH($TEXT(GETACT^DGPFAPI))
SET DGRRNFLG=1
DO NOALRT
+16 if DGRRNFLG=1
QUIT
+17 SET DGPFFLGS=$$GETACT^DGPFAPI(DFN,"DGPFFLGS")
Begin DoDot:2
+18 IF $GET(DGPFFLGS)=0
DO NOALRT
QUIT
+19 DO ADD^DGRRLU(" <businessRule alertId='patientRecordFlag'>")
+20 NEW DGPFI
+21 SET DGPFI=0
+22 FOR
SET DGPFI=$ORDER(DGPFFLGS(DGPFI))
if 'DGPFI
QUIT
Begin DoDot:3
+23 NEW APPRVBY,ASSIGNDT,CATEGORY,FLAG,FLAGTYPE,ORIGSITE,OWNER,REVDT,LINE
+24 SET APPRVBY=$$CHARCHK^DGRRUTL($PIECE($GET(DGPFFLGS(DGPFI,"APPRVBY")),U,2))
+25 SET ASSIGNDT=$PIECE($PIECE($GET(DGPFFLGS(DGPFI,"ASSIGNDT")),U),".")
+26 SET FLAG=$$CHARCHK^DGRRUTL($PIECE($GET(DGPFFLGS(DGPFI,"FLAG")),U,2))
+27 SET FLAGTYPE=$$CHARCHK^DGRRUTL($PIECE($GET(DGPFFLGS(DGPFI,"FLAGTYPE")),U,2))
+28 SET ORIGSITE=$$CHARCHK^DGRRUTL($PIECE($GET(DGPFFLGS(DGPFI,"ORIGSITE")),U,2))
+29 SET OWNER=$$CHARCHK^DGRRUTL($PIECE($GET(DGPFFLGS(DGPFI,"OWNER")),U,2))
+30 SET REVDT=$PIECE($GET(DGPFFLGS(DGPFI,"REVIEWDT")),U)
+31 SET LINE=" <flag flagNumber='"_DGPFI_"' flag='"_FLAG_"' category='"_FLAGTYPE_"' type='"_FLAGTYPE_"' assigndt='"_ASSIGNDT_"' apprvBy='"_APPRVBY_"' revDate='"_REVDT
+32 SET LINE=LINE_"' ownerSite='"_OWNER_"' origSite='"_ORIGSITE_"'>"
+33 DO ADD^DGRRLU(LINE)
+34 DO ADD^DGRRLU(" <narrations>")
+35 NEW DGRRNI
+36 SET DGRRNI=0
+37 FOR
SET DGRRNI=$ORDER(DGPFFLGS(DGPFI,"NARR",DGRRNI))
if 'DGRRNI
QUIT
Begin DoDot:4
+38 NEW DGRRNL
+39 SET DGRRNL=$GET(DGPFFLGS(DGPFI,"NARR",DGRRNI,0))
+40 DO ADD^DGRRLU(" <narration>"_$$CHARCHK^DGRRUTL(DGRRNL)_"</narration>")
End DoDot:4
+41 DO ADD^DGRRLU(" </narrations>")
+42 DO ADD^DGRRLU(" </flag>")
End DoDot:3
+43 DO ADD^DGRRLU(" </businessRule>")
End DoDot:2
End DoDot:1
+44 ;
14 ; -- patient merged -- not a requirement
+1 DO ADD^DGRRLU(" <businessRule alertId='mergedPatient' recordMergedTo='"_$$CHARCHK^DGRRUTL($PIECE($GET(^DPT(DFN,0)),"^",19))_"'></businessRule>")
+2 ;
15 ; -- combat vet status -- being worked on by Edna Curtain.
+1 NEW CVSTATUS,CVEND,DGCV
+2 SET (CVSTATUS,CVEND,DGCV)=""
+3 IF $LENGTH($TEXT(CVEDT^DGCV))
SET DGCV=$$CVEDT^DGCV(+DFN)
+4 IF $PIECE(DGCV,"^")=1
Begin DoDot:1
+5 SET CVSTATUS=$SELECT($PIECE(DGCV,"^",2)>DT:"ELIGIBLE",1:"EXPIRED")
+6 SET CVEND=$PIECE(DGCV,"^",2)
End DoDot:1
+7 DO ADD^DGRRLU(" <businessRule alertId='combatvet' status='"_$$CHARCHK^DGRRUTL($GET(CVSTATUS))_"' endDate='"_$$CHARCHK^DGRRUTL($GET(CVEND))_"'></businessRule>")
16 ;Bad Address Indicator
+1 NEW DGRRBA
+2 SET DGRRBA=$$BADADR^DGUTL3(DFN)
+3 DO ADD^DGRRLU(" <businessRule alertId='badAddress' indicator='"_$$CHARCHK^DGRRUTL($GET(DGRRBA))_"'></businessRule>")
+4 ;
END QUIT
+1 ;
NOALRT ;Returns an empty alert for Patient Record Flag
+1 DO ADD^DGRRLU(" <businessRule alertId='patientRecordFlag'>")
+2 SET LINE=" <flag flagNumber='' category='' type='' assigndt='' apprvBy='' revDate='' ownerSite='' origSite=''>"
+3 DO ADD^DGRRLU(LINE)
+4 DO ADD^DGRRLU(" <narrations></narrations>")
+5 DO ADD^DGRRLU(" </flag>")
+6 DO ADD^DGRRLU(" </businessRule>")
+7 QUIT
