- 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 Jan 18, 2025@03:58:16 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