- PXRMPRF ;SLC/PKR - Computed findings for PRF. ;12/03/2020
- ;;2.0;CLINICAL REMINDERS;**17,18,47,42**;Feb 4, 2005;Build 245
- ;Calls to DGPFAPIU supported by DBIA #4903 and 5491.
- ;==========================================
- GETINF(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;VA-PATIENT RECORD FLAG
- ;INFORMATION computed finding. Return information about a specific
- ;record flag.
- N BDTNT,EDTNTFLAG,FLAGCAT,FLAGNAME,IND,LIST,RESULT,TEMP
- I (TEST="")!(NGET=0) S NFOUND=0 Q
- S FLAGNAME=$P(TEST,U,1)
- S FLAGCAT=$P(TEST,U,2)
- I FLAGCAT="" S FLAGCAT="L"
- S BDTNT=$P(BDT,".",1)
- S EDTNT=$P(EDT,".",1)
- ;DBIA #5491
- S FLAG=$$GETFLAG^DGPFAPIU(FLAGNAME,FLAGCAT)
- ;DBIA #4903
- S RESULT=$$GETINF^DGPFAPIH(DFN,FLAG,BDTNT,EDTNT,"LIST")
- S NFOUND=0
- I RESULT=0 Q
- S IND=0
- F IND=+$O(LIST("HIST",IND)) Q:IND=0 D
- . S NFOUND=NFOUND+1
- . S TEST(NFOUND)=1
- . S DATE(NFOUND)=$P(LIST("HIST",IND,"DATETIME"),U,1)
- . S (DATA(NFOUND,"VALUE"),DATA(NFOUND,"ACTION"))=$P(LIST("HIST",IND,"ACTION"),U,2)
- . S DATA(NFOUND,"APPRVBY")=$P(LIST("HIST",IND,"APPRVBY"),U,2)
- . S DATA(NFOUND,"ASSIGN DT")=$P(LIST("ASSIGNDT"),U,1)
- . S DATA(NFOUND,"CATEGORY")=$P(LIST("CATEGORY"),U,2)
- . S DATA(NFOUND,"FLAGTYPE")=$P(LIST("FLAGTYPE"),U,2)
- . S DATA(NFOUND,"REVIEW DT")=$P(LIST("REVIEWDT"),U,1)
- . S DATA(NFOUND,"TIU TITLE")=$P(LIST("TIUTITLE"),U,2)
- . S TEMP="\\Flag - "_$P(LIST("FLAG"),U,2)_"("_DATA(NFOUND,"CATEGORY")_")."
- . S TEMP=TEMP_"\\Assigned "_$P(LIST("ASSIGNDT"),U,2)_" by "_DATA(NFOUND,"APPRVBY")_". "
- . S TEMP=TEMP_$G(LIST("HIST",IND,"COMMENT",1,0))
- . S TEXT(NFOUND)=TEMP
- Q
- ;
- ;==========================================
- GETLST(NGET,BDT,EDT,PLIST,PARAM) ;VA-PATIENT RECORD FLAG LIST computed finding.
- ;Return a list of patients with a specified record flag.
- N BDTNT,DATE,DFN,EDTNT,FLAGCAT,FLAGNAME,IND,LIST,RESULT
- K ^TMP($J,PLIST)
- I PARAM="" Q
- S FLAGNAME=$P(PARAM,U,1)
- S FLAGCAT=$P(PARAM,U,2)
- I FLAGCAT="" S FLAGCAT="L"
- S BDTNT=$P(BDT,".",1)
- S EDTNT=$P(EDT,".",1)
- ;DBIA #5491
- S FLAG=$$GETFLAG^DGPFAPIU(FLAGNAME,FLAGCAT)
- ;DBIA #4903
- S RESULT=$$GETLST^DGPFAPIH(FLAG,BDTNT,EDTNT,"LIST")
- I RESULT=0 Q
- S DFN=0
- F S DFN=+$O(LIST(DFN)) Q:DFN=0 S ^TMP($J,PLIST,DFN,1)=U_$P(LIST(DFN,0),U,3)_U_U_U
- Q
- ;
- ;==========================================
- PRF(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
- ;getting a list of the patient's active flags.
- N ASSIGNDT,CAT,DONE,FLAG,FLAGKEEP,FLAGLIST,IND
- N NFLAGS,NOCC,OK,SDIR,SUB,TEMP,TYPE
- I (TEST="")!(NGET=0) S NFOUND=0 Q
- ;DBIA #3860
- S NFLAGS=$$GETACT^DGPFAPI(DFN,"FLAGLIST")
- ;If no flags are found quit
- I NFLAGS=0 S NFOUND=0 Q
- S SDIR=$S(NGET<0:1,1:-1)
- S NOCC=$S(NGET<0:-NGET,1:NGET)
- ;Search the parameter list for category, type, and flag.
- S CAT=$F(TEST,"C:")
- I CAT>0 S CAT=$E(TEST,CAT),CAT=$S(CAT="N":"NATIONAL",CAT="L":"LOCAL")
- S TYPE=$F(TEST,"T:")
- I TYPE>0 S TEMP=$E(TEST,TYPE,245),TYPE=$P(TEMP,U,1),TYPE=$S(TYPE="B":"BEHAVIORAL",TYPE="C":"CLINICAL",TYPE="O":"OTHER",TYPE="R":"RESEARCH")
- S FLAG=$F(TEST,"F:")
- I FLAG>0 S TEMP=$E(TEST,FLAG,245),FLAG=$P(TEMP,U,1)
- ;Check all the flags that were returned and keep those that meet
- ;the criteria. Order by assigned date.
- F IND=1:1:NFLAGS D
- . S OK=1
- . I CAT'=0,FLAGLIST(IND,"CATEGORY")'[CAT S OK=0
- . I TYPE'=0,TYPE'=$P(FLAGLIST(IND,"FLAGTYPE"),U,2) S OK=0
- . I FLAG'=0,FLAG'=$P(FLAGLIST(IND,"FLAG"),U,2) S OK=0
- . I OK S FLAGKEEP($P(FLAGLIST(IND,"ASSIGNDT"),U,1),IND)=""
- S ASSIGNDT="",(DONE,NFOUND)=0
- F S ASSIGNDT=$O(FLAGKEEP(ASSIGNDT),SDIR) Q:(DONE)!(ASSIGNDT="") D
- . S IND=0
- . F S IND=$O(FLAGKEEP(ASSIGNDT,IND)) Q:(DONE)!(IND="") D
- .. S NFOUND=NFOUND+1
- .. I NFOUND=NOCC S DONE=1
- .. S TEST(NFOUND)=1
- .. S DATE(NFOUND)=ASSIGNDT
- .. S SUB=""
- ..;Save the CSUB data.
- .. F S SUB=$O(FLAGLIST(IND,SUB)) Q:SUB="" D
- ... I SUB="NARR" Q
- ... S DATA(NFOUND,SUB)=$P($G(FLAGLIST(IND,SUB)),U,2)
- .. S TEXT(NFOUND)=DATA(NFOUND,"FLAG")_"; Category: "_DATA(NFOUND,"CATEGORY")_"; TYPE: "_DATA(NFOUND,"FLAGTYPE")
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMPRF 4038 printed Feb 18, 2025@23:14:59 Page 2
- PXRMPRF ;SLC/PKR - Computed findings for PRF. ;12/03/2020
- +1 ;;2.0;CLINICAL REMINDERS;**17,18,47,42**;Feb 4, 2005;Build 245
- +2 ;Calls to DGPFAPIU supported by DBIA #4903 and 5491.
- +3 ;==========================================
- GETINF(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;VA-PATIENT RECORD FLAG
- +1 ;INFORMATION computed finding. Return information about a specific
- +2 ;record flag.
- +3 NEW BDTNT,EDTNTFLAG,FLAGCAT,FLAGNAME,IND,LIST,RESULT,TEMP
- +4 IF (TEST="")!(NGET=0)
- SET NFOUND=0
- QUIT
- +5 SET FLAGNAME=$PIECE(TEST,U,1)
- +6 SET FLAGCAT=$PIECE(TEST,U,2)
- +7 IF FLAGCAT=""
- SET FLAGCAT="L"
- +8 SET BDTNT=$PIECE(BDT,".",1)
- +9 SET EDTNT=$PIECE(EDT,".",1)
- +10 ;DBIA #5491
- +11 SET FLAG=$$GETFLAG^DGPFAPIU(FLAGNAME,FLAGCAT)
- +12 ;DBIA #4903
- +13 SET RESULT=$$GETINF^DGPFAPIH(DFN,FLAG,BDTNT,EDTNT,"LIST")
- +14 SET NFOUND=0
- +15 IF RESULT=0
- QUIT
- +16 SET IND=0
- +17 FOR IND=+$ORDER(LIST("HIST",IND))
- if IND=0
- QUIT
- Begin DoDot:1
- +18 SET NFOUND=NFOUND+1
- +19 SET TEST(NFOUND)=1
- +20 SET DATE(NFOUND)=$PIECE(LIST("HIST",IND,"DATETIME"),U,1)
- +21 SET (DATA(NFOUND,"VALUE"),DATA(NFOUND,"ACTION"))=$PIECE(LIST("HIST",IND,"ACTION"),U,2)
- +22 SET DATA(NFOUND,"APPRVBY")=$PIECE(LIST("HIST",IND,"APPRVBY"),U,2)
- +23 SET DATA(NFOUND,"ASSIGN DT")=$PIECE(LIST("ASSIGNDT"),U,1)
- +24 SET DATA(NFOUND,"CATEGORY")=$PIECE(LIST("CATEGORY"),U,2)
- +25 SET DATA(NFOUND,"FLAGTYPE")=$PIECE(LIST("FLAGTYPE"),U,2)
- +26 SET DATA(NFOUND,"REVIEW DT")=$PIECE(LIST("REVIEWDT"),U,1)
- +27 SET DATA(NFOUND,"TIU TITLE")=$PIECE(LIST("TIUTITLE"),U,2)
- +28 SET TEMP="\\Flag - "_$PIECE(LIST("FLAG"),U,2)_"("_DATA(NFOUND,"CATEGORY")_")."
- +29 SET TEMP=TEMP_"\\Assigned "_$PIECE(LIST("ASSIGNDT"),U,2)_" by "_DATA(NFOUND,"APPRVBY")_". "
- +30 SET TEMP=TEMP_$GET(LIST("HIST",IND,"COMMENT",1,0))
- +31 SET TEXT(NFOUND)=TEMP
- End DoDot:1
- +32 QUIT
- +33 ;
- +34 ;==========================================
- GETLST(NGET,BDT,EDT,PLIST,PARAM) ;VA-PATIENT RECORD FLAG LIST computed finding.
- +1 ;Return a list of patients with a specified record flag.
- +2 NEW BDTNT,DATE,DFN,EDTNT,FLAGCAT,FLAGNAME,IND,LIST,RESULT
- +3 KILL ^TMP($JOB,PLIST)
- +4 IF PARAM=""
- QUIT
- +5 SET FLAGNAME=$PIECE(PARAM,U,1)
- +6 SET FLAGCAT=$PIECE(PARAM,U,2)
- +7 IF FLAGCAT=""
- SET FLAGCAT="L"
- +8 SET BDTNT=$PIECE(BDT,".",1)
- +9 SET EDTNT=$PIECE(EDT,".",1)
- +10 ;DBIA #5491
- +11 SET FLAG=$$GETFLAG^DGPFAPIU(FLAGNAME,FLAGCAT)
- +12 ;DBIA #4903
- +13 SET RESULT=$$GETLST^DGPFAPIH(FLAG,BDTNT,EDTNT,"LIST")
- +14 IF RESULT=0
- QUIT
- +15 SET DFN=0
- +16 FOR
- SET DFN=+$ORDER(LIST(DFN))
- if DFN=0
- QUIT
- SET ^TMP($JOB,PLIST,DFN,1)=U_$PIECE(LIST(DFN,0),U,3)_U_U_U
- +17 QUIT
- +18 ;
- +19 ;==========================================
- PRF(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
- +1 ;getting a list of the patient's active flags.
- +2 NEW ASSIGNDT,CAT,DONE,FLAG,FLAGKEEP,FLAGLIST,IND
- +3 NEW NFLAGS,NOCC,OK,SDIR,SUB,TEMP,TYPE
- +4 IF (TEST="")!(NGET=0)
- SET NFOUND=0
- QUIT
- +5 ;DBIA #3860
- +6 SET NFLAGS=$$GETACT^DGPFAPI(DFN,"FLAGLIST")
- +7 ;If no flags are found quit
- +8 IF NFLAGS=0
- SET NFOUND=0
- QUIT
- +9 SET SDIR=$SELECT(NGET<0:1,1:-1)
- +10 SET NOCC=$SELECT(NGET<0:-NGET,1:NGET)
- +11 ;Search the parameter list for category, type, and flag.
- +12 SET CAT=$FIND(TEST,"C:")
- +13 IF CAT>0
- SET CAT=$EXTRACT(TEST,CAT)
- SET CAT=$SELECT(CAT="N":"NATIONAL",CAT="L":"LOCAL")
- +14 SET TYPE=$FIND(TEST,"T:")
- +15 IF TYPE>0
- SET TEMP=$EXTRACT(TEST,TYPE,245)
- SET TYPE=$PIECE(TEMP,U,1)
- SET TYPE=$SELECT(TYPE="B":"BEHAVIORAL",TYPE="C":"CLINICAL",TYPE="O":"OTHER",TYPE="R":"RESEARCH")
- +16 SET FLAG=$FIND(TEST,"F:")
- +17 IF FLAG>0
- SET TEMP=$EXTRACT(TEST,FLAG,245)
- SET FLAG=$PIECE(TEMP,U,1)
- +18 ;Check all the flags that were returned and keep those that meet
- +19 ;the criteria. Order by assigned date.
- +20 FOR IND=1:1:NFLAGS
- Begin DoDot:1
- +21 SET OK=1
- +22 IF CAT'=0
- IF FLAGLIST(IND,"CATEGORY")'[CAT
- SET OK=0
- +23 IF TYPE'=0
- IF TYPE'=$PIECE(FLAGLIST(IND,"FLAGTYPE"),U,2)
- SET OK=0
- +24 IF FLAG'=0
- IF FLAG'=$PIECE(FLAGLIST(IND,"FLAG"),U,2)
- SET OK=0
- +25 IF OK
- SET FLAGKEEP($PIECE(FLAGLIST(IND,"ASSIGNDT"),U,1),IND)=""
- End DoDot:1
- +26 SET ASSIGNDT=""
- SET (DONE,NFOUND)=0
- +27 FOR
- SET ASSIGNDT=$ORDER(FLAGKEEP(ASSIGNDT),SDIR)
- if (DONE)!(ASSIGNDT="")
- QUIT
- Begin DoDot:1
- +28 SET IND=0
- +29 FOR
- SET IND=$ORDER(FLAGKEEP(ASSIGNDT,IND))
- if (DONE)!(IND="")
- QUIT
- Begin DoDot:2
- +30 SET NFOUND=NFOUND+1
- +31 IF NFOUND=NOCC
- SET DONE=1
- +32 SET TEST(NFOUND)=1
- +33 SET DATE(NFOUND)=ASSIGNDT
- +34 SET SUB=""
- +35 ;Save the CSUB data.
- +36 FOR
- SET SUB=$ORDER(FLAGLIST(IND,SUB))
- if SUB=""
- QUIT
- Begin DoDot:3
- +37 IF SUB="NARR"
- QUIT
- +38 SET DATA(NFOUND,SUB)=$PIECE($GET(FLAGLIST(IND,SUB)),U,2)
- End DoDot:3
- +39 SET TEXT(NFOUND)=DATA(NFOUND,"FLAG")_"; Category: "_DATA(NFOUND,"CATEGORY")_"; TYPE: "_DATA(NFOUND,"FLAGTYPE")
- End DoDot:2
- End DoDot:1
- +40 QUIT
- +41 ;