- 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 Feb 18, 2025@23:15:23 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 ;