PXRMRULE ;SLC/PJH - Build Patient list from Rule Set ;08/16/2018
;;2.0;CLINICAL REMINDERS;**4,6,42**;Feb 04, 2005;Build 245
;
; Called from PXRM PATIENT LIST CREATE protocol
;
CLEAR(RULE,NODE) ;Clear workfile entries
N SEQ
S SEQ=""
F S SEQ=$O(^PXRM(810.4,RULE,30,"B",SEQ)) Q:'SEQ D
.K ^TMP($J,NODE_SEQ)
;clear FDA array
K ^TMP($J,"PXRMFDA")
Q
;
INTR ;Input transform for #810.4 fields
Q
;
LOAD(NODE,LIEN) ;Load Patient List
N DATA,DFN,SUB
S SUB=0
F S SUB=$O(^PXRMXP(810.5,LIEN,30,SUB)) Q:'SUB D
.S DATA=$G(^PXRMXP(810.5,LIEN,30,SUB,0)),DFN=$P(DATA,U) Q:'DFN
.;Store the patient IEN and institution in ^TMP
.S ^TMP($J,NODE,DFN)=$P(DATA,U,2)_U_$P($G(DATA),U,3)_U_$P($G(DATA),U,4)
Q
;
PATS(FRACT,FROUT,PNODE,LIST) ;Process Patient List finding rule
;
N LIEN,LUVALUE
;Insert year and period into extract list name
I YEAR]"",LIST["yyyy" S LIST=$P(LIST,"yyyy")_YEAR_$P(LIST,"yyyy",2)
I PERIOD]"",LIST["nn" S LIST=$P(LIST,"nn")_$E(PERIOD,2,10)_$P(LIST,"nn",2)
;
S LUVALUE(1)=LIST
S LIEN=+$$FIND1^DIC(810.5,"","KUX",.LUVALUE) Q:'LIEN
;
;Add operation Load list
I FRACT="A" D LOAD(FROUT,LIEN) Q
;
;Remove or Select operations
;Load List
D LOAD(PNODE,LIEN)
;Check each patient
S DFN=0
F S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN D
.;Delete any ^TMP patient in PLIST if action is remove
.I FRACT="R",$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN) Q
.;Delete any ^TMP patient not in PLIST if action is select
.I FRACT="S",'$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN)
Q
;
START(RULESET,LIST,NODE,LBBDT,LBEDT,PAR,YEAR,PERIOD,INDP,INTP,EXTITR) ;
;Process rule set
;Clear ^TMP
D CLEAR(RULESET,NODE)
;
N CLASS,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,INC,INST,PXRMDATE,PXRMDDOC
N RBDT,REDT,RRIEN,RSDATA,RSDATES,SEQ,SUB
;Get class from extract parameter
I PAR S CLASS=$P($G(^PXRM(810.2,PAR,100)),U)
;Otherwise default to local
I $G(CLASS)="" S CLASS="L"
;PXRMDDOC=1 save list rule evaluation dates in ^TMP("PXRMDDOC",$J)
S PXRMDDOC=1
K ^TMP("PXRMDDOC",$J)
;Get each finding rule in sequence
S SEQ="",INC=0,INST=0
F S SEQ=$O(^PXRM(810.4,RULESET,30,"B",SEQ)) Q:'SEQ D
.;Save first sequence as default
.I INC=0 S INC=1,FSEQ=SEQ
.S SUB=$O(^PXRM(810.4,RULESET,30,"B",SEQ,"")) Q:'SUB
.S RSDATA=$G(^PXRM(810.4,RULESET,30,SUB,0)) Q:RSDATA=""
.S RSDATES=$G(^PXRM(810.4,RULESET,30,SUB,1))
.;Finding rule IEN and action
.S FRIEN=$P(RSDATA,U,2),FRACT=$P(RSDATA,U,3) Q:'FRIEN Q:FRACT=""
.;Check if entry is a finding rule (not a set or reminder rule)
.S FRDATA=$G(^PXRM(810.4,FRIEN,0)),FRTYP=$P(FRDATA,U,3) Q:FRTYP=3
.S FRDATES=$P(FRDATA,U,4,5)
.;Get term IEN for finding rule
.I FRTYP=1 S FRTIEN=$P(FRDATA,U,7) Q:'FRTIEN
.;Get Reminder definition IEN for Reminder rule
.I FRTYP=2 S RRIEN=$P(FRDATA,U,10) Q:'RRIEN
.;Get Extract Patient List name for patient list rule
.I FRTYP=5 S FRLST=$P($G(^PXRM(810.4,FRIEN,1)),U) D Q:FRLST=""
..I +EXTITR>0 S FRLST=FRLST_"/"_EXTITR
..S FROLST=$P(FRDATA,U,8)
..I +FROLST>0 S FRLST=$P($G(^PXRMXP(810.5,FROLST,0)),U)
.;Determine RBDT and REDT
.D RDATES^PXRMEUT1(RSDATES,FRDATES,LBBDT,LBEDT,.RBDT,.REDT)
.S PXRMDATE=LBEDT
.;Get start sequence or start patient list
.S FRSTRT=$P(RSDATA,U,4),FRPAT=$P(RSDATA,U,5)
.;If sequence is defined use it
.I FRSTRT S FROUT=NODE_FRSTRT
.;If neither exist use first as default
.I FRSTRT="",FRPAT="" S FROUT=NODE_FSEQ
.;If start is patient list load patient list into workfile
.I FRSTRT="",FRPAT]"" S FROUT=NODE_SEQ D LOAD(FROUT,FRPAT)
.;Name of permanent list
.S FRPERM=$P(RSDATA,U,6)
.;
.;Build patient list in TMP
.N DFN,PNODE
.S PNODE="PXRMEVAL"
.K ^TMP($J,PNODE)
.;Term finding rules
.I FRTYP=1 D TERM^PXRMRUL1(FRACT,FRTIEN,LBBDT,LBEDT,RBDT,REDT,PNODE,.INST)
.;Reminder Definition List Rule
.I FRTYP=2 D REM^PXRMRUL1(FRACT,RRIEN,LBBDT,LBEDT,RBDT,REDT,PNODE)
.;Patient list finding rules
.I FRTYP=5 D PATS(FRACT,FROUT,PNODE,FRLST)
.;Clear results file
.K ^TMP($J,PNODE)
.;
.;Build permanent list if required
.I FRPERM]"" D
..N FRPIEN
..;Get patient list IEN or create new patient list
..S FRPIEN=$$CRLST^PXRMRUL1(FRPERM,CLASS) Q:'FRPIEN
..;Update patient list
..D UPDLST(FROUT,FRPIEN,PAR,RULESET,INST,INDP,INTP)
;
;Save final results to patient list
I LIST'="",FROUT'="" D
. D RMPAT^PXRMEUT(FROUT,INDP,INTP)
. D UPDLST(FROUT,LIST,PAR,RULESET,INST,INDP,INTP)
.;PXRMDDOC=2 compare saved dates with those generated in
.;DOCUMENT^PXRMEUT.
. S PXRMDDOC=2
. D DOCUMENT^PXRMEUT(LIST,RULESET,INDP,INTP,LBBDT,LBEDT)
K ^TMP("PXRMDDOC",$J)
Q
;
UPDLST(NODE,LIST,EPIEN,RULE,INST,INDP,INTP) ;Update patient list
N CNT,DA,DATA,DCNT,DECEASED,DFN,DNAME,DNAMEL,DOD,DUE,DUOUT,FDA
N INSTNAM,INSTNUM,LAST,MSG,NAME,ONODE
N RCNT,RIEN,RNAMEL,RNCNT,SUB,TEMP,TEST,TYPE,VALUE
;Lock patient list
D LOCK^PXRMRUL1 Q:$D(DUOUT)
S TEMP=^PXRMXP(810.5,LIST,0)
S NAME=$P(TEMP,U,1)
S $P(^PXRMXP(810.5,LIST,0),U,11)=INDP
S $P(^PXRMXP(810.5,LIST,0),U,12)=INTP
;
;Clear existing list.
K ^PXRMXP(810.5,LIST,30),^PXRMXP(810.5,LIST,35),^PXRMXP(810.5,LIST,45),^PXRMXP(810.5,LIST,200)
;
;Merge ^TMP into Patient List
S (DECEASED,TESTP)=""
S (CNT,DFN)=0
F S DFN=$O(^TMP($J,NODE,DFN)) Q:'DFN D
.S ONODE=$G(^TMP($J,NODE,DFN,"INST"))
.S INSTNUM=$P(ONODE,U,1),INSTNAM=$P(ONODE,U,2)
.S TEMP=DFN_U_INSTNUM_U_INSTNAM
.I INDP D
..;DBIA #10035
..S DOD=+$P($G(^DPT(DFN,.35)),U,1)
..S DECEASED=$S(DOD=0:0,1:1)
.;DBIA #3744
.I INTP S TESTP=$$TESTPAT^VADPT(DFN)
.S CNT=CNT+1,^PXRMXP(810.5,LIST,30,CNT,0)=DFN_U_INSTNUM_U_INSTNAM_U_DECEASED_U_TESTP
.S ^PXRMXP(810.5,LIST,30,"B",DFN,CNT)=""
.;
.;Save the reminder evaluation information only from Reports
.I $D(^TMP($J,NODE,DFN,"REM"))>0 D
..S (RIEN,RCNT,RNCNT)=0
..F S RIEN=$O(^TMP($J,NODE,DFN,"REM",RIEN)) Q:RIEN'>0 D
...S RNAMEL(RIEN)=""
...S VALUE=^TMP($J,NODE,DFN,"REM",RIEN)
...S RCNT=RCNT+1
...S ^PXRMXP(810.5,LIST,30,CNT,"REM",RCNT,0)=VALUE
...S ^PXRMXP(810.5,LIST,30,CNT,"REM","B",RIEN,RCNT)=""
..S ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.532A"_U_RCNT_U_RCNT
.;
.I '$D(^TMP($J,NODE,DFN,"DATA")) Q
.S DCNT=0,DNAME=""
.F S DNAME=$O(^TMP($J,NODE,DFN,"DATA",DNAME)) Q:DNAME="" D
..S DNAMEL(DNAME)=""
..S VALUE=^TMP($J,NODE,DFN,"DATA",DNAME)
..S DCNT=DCNT+1
..S ^PXRMXP(810.5,LIST,30,CNT,"DATA",DCNT,0)=DNAME_U_VALUE
..S ^PXRMXP(810.5,LIST,30,CNT,"DATA","B",DNAME,DCNT)=""
.S ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.531A"_U_DCNT_U_DCNT
S ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT
;
;Save the reminder information
S RNCNT=0,RIEN=0
F S RIEN=$O(RNAMEL(RIEN)) Q:RIEN'>0 D
.S RNCNT=RNCNT+1
.S ^PXRMXP(810.5,LIST,45,RCNT,0)=RIEN
.S ^PXRMXP(810.5,LIST,45,"B",RIEN,RNCNT)=""
I RNCNT>0 S ^PXRMXP(810.5,LIST,45,0)=U_"810.545P"_U_RNCNT_U_RNCNT
;
;Save the data types.
S DCNT=0,DNAME=""
F S DNAME=$O(DNAMEL(DNAME)) Q:DNAME="" D
.S DCNT=DCNT+1
.S ^PXRMXP(810.5,LIST,35,DCNT,0)=DNAME
.S ^PXRMXP(810.5,LIST,35,"B",DNAME,DCNT)=""
I DCNT>0 S ^PXRMXP(810.5,LIST,35,0)=U_"810.535A"_U_DCNT_U_DCNT
S ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT
;
;Update header info
S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")
K PATCREAT
S FDA(810.5,"?+1,",.01)=NAME
S FDA(810.5,"?+1,",.04)=$$NOW^XLFDT
S FDA(810.5,"?+1,",.05)=EPIEN
S FDA(810.5,"?+1,",.06)=RULE
S FDA(810.5,"?+1,",.07)=$G(DUZ)
S FDA(810.5,"?+1,",.08)=TYPE
I $G(INST)=1 S FDA(810.5,"?+1,",.1)=1
S FDA(810.5,"?+1,",50)=$S($G(PLISTPUG)="Y":1,1:0)
D UPDATE^DIE("","FDA","","MSG")
;Error
I $D(MSG) D ERR^PXRMRUL1
;Unlock patient list
D UNLOCK^PXRMRUL1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMRULE 7719 printed Dec 13, 2024@01:49 Page 2
PXRMRULE ;SLC/PJH - Build Patient list from Rule Set ;08/16/2018
+1 ;;2.0;CLINICAL REMINDERS;**4,6,42**;Feb 04, 2005;Build 245
+2 ;
+3 ; Called from PXRM PATIENT LIST CREATE protocol
+4 ;
CLEAR(RULE,NODE) ;Clear workfile entries
+1 NEW SEQ
+2 SET SEQ=""
+3 FOR
SET SEQ=$ORDER(^PXRM(810.4,RULE,30,"B",SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+4 KILL ^TMP($JOB,NODE_SEQ)
End DoDot:1
+5 ;clear FDA array
+6 KILL ^TMP($JOB,"PXRMFDA")
+7 QUIT
+8 ;
INTR ;Input transform for #810.4 fields
+1 QUIT
+2 ;
LOAD(NODE,LIEN) ;Load Patient List
+1 NEW DATA,DFN,SUB
+2 SET SUB=0
+3 FOR
SET SUB=$ORDER(^PXRMXP(810.5,LIEN,30,SUB))
if 'SUB
QUIT
Begin DoDot:1
+4 SET DATA=$GET(^PXRMXP(810.5,LIEN,30,SUB,0))
SET DFN=$PIECE(DATA,U)
if 'DFN
QUIT
+5 ;Store the patient IEN and institution in ^TMP
+6 SET ^TMP($JOB,NODE,DFN)=$PIECE(DATA,U,2)_U_$PIECE($GET(DATA),U,3)_U_$PIECE($GET(DATA),U,4)
End DoDot:1
+7 QUIT
+8 ;
PATS(FRACT,FROUT,PNODE,LIST) ;Process Patient List finding rule
+1 ;
+2 NEW LIEN,LUVALUE
+3 ;Insert year and period into extract list name
+4 IF YEAR]""
IF LIST["yyyy"
SET LIST=$PIECE(LIST,"yyyy")_YEAR_$PIECE(LIST,"yyyy",2)
+5 IF PERIOD]""
IF LIST["nn"
SET LIST=$PIECE(LIST,"nn")_$EXTRACT(PERIOD,2,10)_$PIECE(LIST,"nn",2)
+6 ;
+7 SET LUVALUE(1)=LIST
+8 SET LIEN=+$$FIND1^DIC(810.5,"","KUX",.LUVALUE)
if 'LIEN
QUIT
+9 ;
+10 ;Add operation Load list
+11 IF FRACT="A"
DO LOAD(FROUT,LIEN)
QUIT
+12 ;
+13 ;Remove or Select operations
+14 ;Load List
+15 DO LOAD(PNODE,LIEN)
+16 ;Check each patient
+17 SET DFN=0
+18 FOR
SET DFN=$ORDER(^TMP($JOB,FROUT,DFN))
if 'DFN
QUIT
Begin DoDot:1
+19 ;Delete any ^TMP patient in PLIST if action is remove
+20 IF FRACT="R"
IF $DATA(^TMP($JOB,PNODE,DFN))
KILL ^TMP($JOB,FROUT,DFN)
QUIT
+21 ;Delete any ^TMP patient not in PLIST if action is select
+22 IF FRACT="S"
IF '$DATA(^TMP($JOB,PNODE,DFN))
KILL ^TMP($JOB,FROUT,DFN)
End DoDot:1
+23 QUIT
+24 ;
START(RULESET,LIST,NODE,LBBDT,LBEDT,PAR,YEAR,PERIOD,INDP,INTP,EXTITR) ;
+1 ;Process rule set
+2 ;Clear ^TMP
+3 DO CLEAR(RULESET,NODE)
+4 ;
+5 NEW CLASS,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
+6 NEW FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,INC,INST,PXRMDATE,PXRMDDOC
+7 NEW RBDT,REDT,RRIEN,RSDATA,RSDATES,SEQ,SUB
+8 ;Get class from extract parameter
+9 IF PAR
SET CLASS=$PIECE($GET(^PXRM(810.2,PAR,100)),U)
+10 ;Otherwise default to local
+11 IF $GET(CLASS)=""
SET CLASS="L"
+12 ;PXRMDDOC=1 save list rule evaluation dates in ^TMP("PXRMDDOC",$J)
+13 SET PXRMDDOC=1
+14 KILL ^TMP("PXRMDDOC",$JOB)
+15 ;Get each finding rule in sequence
+16 SET SEQ=""
SET INC=0
SET INST=0
+17 FOR
SET SEQ=$ORDER(^PXRM(810.4,RULESET,30,"B",SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+18 ;Save first sequence as default
+19 IF INC=0
SET INC=1
SET FSEQ=SEQ
+20 SET SUB=$ORDER(^PXRM(810.4,RULESET,30,"B",SEQ,""))
if 'SUB
QUIT
+21 SET RSDATA=$GET(^PXRM(810.4,RULESET,30,SUB,0))
if RSDATA=""
QUIT
+22 SET RSDATES=$GET(^PXRM(810.4,RULESET,30,SUB,1))
+23 ;Finding rule IEN and action
+24 SET FRIEN=$PIECE(RSDATA,U,2)
SET FRACT=$PIECE(RSDATA,U,3)
if 'FRIEN
QUIT
if FRACT=""
QUIT
+25 ;Check if entry is a finding rule (not a set or reminder rule)
+26 SET FRDATA=$GET(^PXRM(810.4,FRIEN,0))
SET FRTYP=$PIECE(FRDATA,U,3)
if FRTYP=3
QUIT
+27 SET FRDATES=$PIECE(FRDATA,U,4,5)
+28 ;Get term IEN for finding rule
+29 IF FRTYP=1
SET FRTIEN=$PIECE(FRDATA,U,7)
if 'FRTIEN
QUIT
+30 ;Get Reminder definition IEN for Reminder rule
+31 IF FRTYP=2
SET RRIEN=$PIECE(FRDATA,U,10)
if 'RRIEN
QUIT
+32 ;Get Extract Patient List name for patient list rule
+33 IF FRTYP=5
SET FRLST=$PIECE($GET(^PXRM(810.4,FRIEN,1)),U)
Begin DoDot:2
+34 IF +EXTITR>0
SET FRLST=FRLST_"/"_EXTITR
+35 SET FROLST=$PIECE(FRDATA,U,8)
+36 IF +FROLST>0
SET FRLST=$PIECE($GET(^PXRMXP(810.5,FROLST,0)),U)
End DoDot:2
if FRLST=""
QUIT
+37 ;Determine RBDT and REDT
+38 DO RDATES^PXRMEUT1(RSDATES,FRDATES,LBBDT,LBEDT,.RBDT,.REDT)
+39 SET PXRMDATE=LBEDT
+40 ;Get start sequence or start patient list
+41 SET FRSTRT=$PIECE(RSDATA,U,4)
SET FRPAT=$PIECE(RSDATA,U,5)
+42 ;If sequence is defined use it
+43 IF FRSTRT
SET FROUT=NODE_FRSTRT
+44 ;If neither exist use first as default
+45 IF FRSTRT=""
IF FRPAT=""
SET FROUT=NODE_FSEQ
+46 ;If start is patient list load patient list into workfile
+47 IF FRSTRT=""
IF FRPAT]""
SET FROUT=NODE_SEQ
DO LOAD(FROUT,FRPAT)
+48 ;Name of permanent list
+49 SET FRPERM=$PIECE(RSDATA,U,6)
+50 ;
+51 ;Build patient list in TMP
+52 NEW DFN,PNODE
+53 SET PNODE="PXRMEVAL"
+54 KILL ^TMP($JOB,PNODE)
+55 ;Term finding rules
+56 IF FRTYP=1
DO TERM^PXRMRUL1(FRACT,FRTIEN,LBBDT,LBEDT,RBDT,REDT,PNODE,.INST)
+57 ;Reminder Definition List Rule
+58 IF FRTYP=2
DO REM^PXRMRUL1(FRACT,RRIEN,LBBDT,LBEDT,RBDT,REDT,PNODE)
+59 ;Patient list finding rules
+60 IF FRTYP=5
DO PATS(FRACT,FROUT,PNODE,FRLST)
+61 ;Clear results file
+62 KILL ^TMP($JOB,PNODE)
+63 ;
+64 ;Build permanent list if required
+65 IF FRPERM]""
Begin DoDot:2
+66 NEW FRPIEN
+67 ;Get patient list IEN or create new patient list
+68 SET FRPIEN=$$CRLST^PXRMRUL1(FRPERM,CLASS)
if 'FRPIEN
QUIT
+69 ;Update patient list
+70 DO UPDLST(FROUT,FRPIEN,PAR,RULESET,INST,INDP,INTP)
End DoDot:2
End DoDot:1
+71 ;
+72 ;Save final results to patient list
+73 IF LIST'=""
IF FROUT'=""
Begin DoDot:1
+74 DO RMPAT^PXRMEUT(FROUT,INDP,INTP)
+75 DO UPDLST(FROUT,LIST,PAR,RULESET,INST,INDP,INTP)
+76 ;PXRMDDOC=2 compare saved dates with those generated in
+77 ;DOCUMENT^PXRMEUT.
+78 SET PXRMDDOC=2
+79 DO DOCUMENT^PXRMEUT(LIST,RULESET,INDP,INTP,LBBDT,LBEDT)
End DoDot:1
+80 KILL ^TMP("PXRMDDOC",$JOB)
+81 QUIT
+82 ;
UPDLST(NODE,LIST,EPIEN,RULE,INST,INDP,INTP) ;Update patient list
+1 NEW CNT,DA,DATA,DCNT,DECEASED,DFN,DNAME,DNAMEL,DOD,DUE,DUOUT,FDA
+2 NEW INSTNAM,INSTNUM,LAST,MSG,NAME,ONODE
+3 NEW RCNT,RIEN,RNAMEL,RNCNT,SUB,TEMP,TEST,TYPE,VALUE
+4 ;Lock patient list
+5 DO LOCK^PXRMRUL1
if $DATA(DUOUT)
QUIT
+6 SET TEMP=^PXRMXP(810.5,LIST,0)
+7 SET NAME=$PIECE(TEMP,U,1)
+8 SET $PIECE(^PXRMXP(810.5,LIST,0),U,11)=INDP
+9 SET $PIECE(^PXRMXP(810.5,LIST,0),U,12)=INTP
+10 ;
+11 ;Clear existing list.
+12 KILL ^PXRMXP(810.5,LIST,30),^PXRMXP(810.5,LIST,35),^PXRMXP(810.5,LIST,45),^PXRMXP(810.5,LIST,200)
+13 ;
+14 ;Merge ^TMP into Patient List
+15 SET (DECEASED,TESTP)=""
+16 SET (CNT,DFN)=0
+17 FOR
SET DFN=$ORDER(^TMP($JOB,NODE,DFN))
if 'DFN
QUIT
Begin DoDot:1
+18 SET ONODE=$GET(^TMP($JOB,NODE,DFN,"INST"))
+19 SET INSTNUM=$PIECE(ONODE,U,1)
SET INSTNAM=$PIECE(ONODE,U,2)
+20 SET TEMP=DFN_U_INSTNUM_U_INSTNAM
+21 IF INDP
Begin DoDot:2
+22 ;DBIA #10035
+23 SET DOD=+$PIECE($GET(^DPT(DFN,.35)),U,1)
+24 SET DECEASED=$SELECT(DOD=0:0,1:1)
End DoDot:2
+25 ;DBIA #3744
+26 IF INTP
SET TESTP=$$TESTPAT^VADPT(DFN)
+27 SET CNT=CNT+1
SET ^PXRMXP(810.5,LIST,30,CNT,0)=DFN_U_INSTNUM_U_INSTNAM_U_DECEASED_U_TESTP
+28 SET ^PXRMXP(810.5,LIST,30,"B",DFN,CNT)=""
+29 ;
+30 ;Save the reminder evaluation information only from Reports
+31 IF $DATA(^TMP($JOB,NODE,DFN,"REM"))>0
Begin DoDot:2
+32 SET (RIEN,RCNT,RNCNT)=0
+33 FOR
SET RIEN=$ORDER(^TMP($JOB,NODE,DFN,"REM",RIEN))
if RIEN'>0
QUIT
Begin DoDot:3
+34 SET RNAMEL(RIEN)=""
+35 SET VALUE=^TMP($JOB,NODE,DFN,"REM",RIEN)
+36 SET RCNT=RCNT+1
+37 SET ^PXRMXP(810.5,LIST,30,CNT,"REM",RCNT,0)=VALUE
+38 SET ^PXRMXP(810.5,LIST,30,CNT,"REM","B",RIEN,RCNT)=""
End DoDot:3
+39 SET ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.532A"_U_RCNT_U_RCNT
End DoDot:2
+40 ;
+41 IF '$DATA(^TMP($JOB,NODE,DFN,"DATA"))
QUIT
+42 SET DCNT=0
SET DNAME=""
+43 FOR
SET DNAME=$ORDER(^TMP($JOB,NODE,DFN,"DATA",DNAME))
if DNAME=""
QUIT
Begin DoDot:2
+44 SET DNAMEL(DNAME)=""
+45 SET VALUE=^TMP($JOB,NODE,DFN,"DATA",DNAME)
+46 SET DCNT=DCNT+1
+47 SET ^PXRMXP(810.5,LIST,30,CNT,"DATA",DCNT,0)=DNAME_U_VALUE
+48 SET ^PXRMXP(810.5,LIST,30,CNT,"DATA","B",DNAME,DCNT)=""
End DoDot:2
+49 SET ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.531A"_U_DCNT_U_DCNT
End DoDot:1
+50 SET ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT
+51 ;
+52 ;Save the reminder information
+53 SET RNCNT=0
SET RIEN=0
+54 FOR
SET RIEN=$ORDER(RNAMEL(RIEN))
if RIEN'>0
QUIT
Begin DoDot:1
+55 SET RNCNT=RNCNT+1
+56 SET ^PXRMXP(810.5,LIST,45,RCNT,0)=RIEN
+57 SET ^PXRMXP(810.5,LIST,45,"B",RIEN,RNCNT)=""
End DoDot:1
+58 IF RNCNT>0
SET ^PXRMXP(810.5,LIST,45,0)=U_"810.545P"_U_RNCNT_U_RNCNT
+59 ;
+60 ;Save the data types.
+61 SET DCNT=0
SET DNAME=""
+62 FOR
SET DNAME=$ORDER(DNAMEL(DNAME))
if DNAME=""
QUIT
Begin DoDot:1
+63 SET DCNT=DCNT+1
+64 SET ^PXRMXP(810.5,LIST,35,DCNT,0)=DNAME
+65 SET ^PXRMXP(810.5,LIST,35,"B",DNAME,DCNT)=""
End DoDot:1
+66 IF DCNT>0
SET ^PXRMXP(810.5,LIST,35,0)=U_"810.535A"_U_DCNT_U_DCNT
+67 SET ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT
+68 ;
+69 ;Update header info
+70 SET TYPE=$SELECT($GET(PATCREAT)="Y":"PVT",1:"PUB")
+71 KILL PATCREAT
+72 SET FDA(810.5,"?+1,",.01)=NAME
+73 SET FDA(810.5,"?+1,",.04)=$$NOW^XLFDT
+74 SET FDA(810.5,"?+1,",.05)=EPIEN
+75 SET FDA(810.5,"?+1,",.06)=RULE
+76 SET FDA(810.5,"?+1,",.07)=$GET(DUZ)
+77 SET FDA(810.5,"?+1,",.08)=TYPE
+78 IF $GET(INST)=1
SET FDA(810.5,"?+1,",.1)=1
+79 SET FDA(810.5,"?+1,",50)=$SELECT($GET(PLISTPUG)="Y":1,1:0)
+80 DO UPDATE^DIE("","FDA","","MSG")
+81 ;Error
+82 IF $DATA(MSG)
DO ERR^PXRMRUL1
+83 ;Unlock patient list
+84 DO UNLOCK^PXRMRUL1
+85 QUIT
+86 ;
