Changeset 623 for WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETX.m

Timestamp:

Dec 4, 2009, 12:11:15 AM (14 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

File:

• WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETX.m (modified) (1 diff)

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETX.m

@@ -1 @@
-PXRMETX ; SLC/PJH - Run Extract for QUERI ;11:42 AM  17 Dec 2008
-        ;;2.0;CLINICAL REMINDERS;**4,6,7**;Feb 04, 2005;Build 1
-        ; Modified from FOIA VISTA,
-        ; Copyright (C) 2007 WorldVistA
-        ;
-        ; This program is free software; you can redistribute it and/or modify
-        ; it under the terms of the GNU General Public License as published by
-        ; the Free Software Foundation; either version 2 of the License, or
-        ; (at your option) any later version.
-        ;
-        ; This program is distributed in the hope that it will be useful,
-        ; but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ; GNU General Public License for more details.
-        ;
-        ; You should have received a copy of the GNU General Public License
-        ; along with this program; if not, write to the Free Software
-        ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
-        ;
-        ;
-AUTO(ID,PURGE)  ;Called from option scheduling (#19.2)
-        N IEN,LIST,LUVALUE,MODE,NEXT
-        S LUVALUE(1)=ID
-        D FIND^DIC(810.2,"","","U",.LUVALUE,"","","","","LIST")
-        ;Get ien of extract parameter
-        S IEN=$P(LIST("DILIST",2,1),U,1) Q:'IEN
-        ;Get next extract period
-        S NEXT=$P($G(^PXRM(810.2,IEN,0)),U,6) Q:NEXT=""
-        ;Node is Extract and Transmit
-        S MODE=$S($P($G(^PXRM(810.2,IEN,100)),U)="N":0,1:1)
-        ;Run extract
-        D RUN^PXRMETX(IEN,NEXT,MODE,PURGE)
-        ;Purge Extract Summary
-        D PRGES^PXRMETXU
-        ;Purge Patient Lists
-        D PRGPL^PXRMETXU
-        Q
-        ;
-GETNAME(NAME,CLASS)     ;Get the extract name.
-        I '$D(^PXRMXT(810.3,"B",NAME)) Q NAME
-        N CNT,NEW
-        S (CNT,NEW)=0
-        ;If name exists concatenate count
-        F  D  Q:NEW
-        .I '$D(^PXRMXT(810.3,"B",NAME)) S NEW=1 Q
-        .S CNT=CNT+1,NAME=$P(NAME,"/")_"/"_$$RJ^XLFSTR(CNT,2,0)
-        Q NAME
-        ;
-IHD     ;Monthly IHD Extract, called from option PXRM EXTRACT VA-IHD QUERI.
-        D AUTO("VA-IHD QUERI","Y")
-        Q
-        ;
-MAIL(NAME,NEXT,MODE)    ;Completion mail message
-        N FREQ,TEXT
-        S FREQ="year"
-        I $E(NEXT)="M" S FREQ="month"
-        I $E(NEXT)="Q" S FREQ="quarter"
-        ;
-        I MODE=0 S TEXT="Extract and Transmission"
-        I MODE=1 S TEXT="Extract (No Transmission)"
-        I MODE=2 S TEXT="Manual Extract and Transmission"
-        I MODE=3 S TEXT="Manual Extract (No Transmission)"
-        ;
-        S TEXT=NAME_" "_TEXT_" completed for "_FREQ_" "_NEXT
-        D MES^PXRMEUT(TEXT)
-        Q
-        ;
-MH      ;Monthly MH Extract, called from option PXRM EXTRACT VA-MH QUERI.
-        D AUTO("VA-MH QUERI","Y")
-        Q
-        ;
-        ;Begin WV change wv/so 12/17/2008
-        ;
-ACAD    ;Auto CAD entry point
-        D AUTO("VOE DOQ-IT CAD EXTRACTION")
-        Q
-        ;
-ADM     ;Auto DM entry point
-        D AUTO("VOE DOQ-IT DM EXTRACTION")
-        Q
-        ;
-AHF     ;Auto HF entry point
-        D AUTO("VOE DOQ-IT HF EXTRACTION")
-        Q
-        ;
-AHTN    ;Auto HTN entry point
-        D AUTO("VOE DOQ-IT HTN EXTRACTION")
-        Q
-        ;
-APC     ;Auto PC entry point
-        D AUTO("VOE DOQ-IT PC EXTRACTION")
-        Q
-        ;End WV change
-        ;
-RUN(IEN,NEXT,MODE,PURGE)        ;Process extract parameter
-        ; IEN is ien of Extract Parameter
-        ; NEXT is period to extract
-        ; MODE = 0 is extract and transmission
-        ; MODE = 1 is extract only
-        ; MODE = 2 is manual extract and transmission (doesn't update 810.2)
-        ; MODE = 3 is manual extract only (doesn't update 810.2)
-        ;
-        N CLASS,FDA,FDAIEN,MSG
-        N PXRMIDOD,PXRMLIST,PXRMNODE,PXRMRULE,PXRMSTRT,PXRMXIEN,PATCREAT,XNAME
-        N ITER
-        ;Initialise
-        K ^TMP("PXRMETX",$J),^TMP("PXRMETX1",$J)
-        ;Workfile node for ^TMP
-        S PXRMNODE="PXRMRULE"
-        ;Get details from parameter file
-        N DATA,INDP,INTP,LIST,NAME,PARTYPE,PERIOD,SNAME,TEXT,YEAR
-        ;Get class from extract parameter
-        S CLASS=$P($G(^PXRM(810.2,IEN,100)),U)
-        ;Otherwise default to local
-        I $G(CLASS)="" S CLASS="L"
-        ;
-        S DATA=$G(^PXRM(810.2,IEN,0))
-        ;Determine Extract Name and period
-        S NAME=$P(DATA,U),PARTYPE=$P(DATA,U,2)
-        S YEAR=$P(NEXT,"/",2),PERIOD=$P(NEXT,"/")
-        ;Calculate report period start and end dates
-        D CALC^PXRMEUT(NEXT,.PXRMSTRT,.PXRMSTOP)
-        ;Determine output name for patient list and extract summary
-        S XNAME=NAME_" "_YEAR_" "_PERIOD
-        S NAME=$$GETNAME(XNAME)
-        S ITER=$P(NAME,"/",2)
-        ;Process (single) Denominator rule into patient list
-        N SEQ,SUB
-        S SEQ=""
-        F  S SEQ=$O(^PXRM(810.2,IEN,10,"B",SEQ)) Q:'SEQ  D
-        .S SUB=$O(^PXRM(810.2,IEN,10,"B",SEQ,"")) Q:'SUB
-        .S DATA=$G(^PXRM(810.2,IEN,10,SUB,0)) Q:DATA=""
-        .S PXRMRULE=$P(DATA,U,2) Q:'PXRMRULE
-        .S LIST=$P(DATA,U,3) Q:LIST=""
-        .I LIST["yyyy" S LIST=$P(LIST,"yyyy")_YEAR_$P(LIST,"yyyy",2)
-        .I LIST["nn" S LIST=$P(LIST,"nn")_$E(PERIOD,2,10)_$P(LIST,"nn",2)
-        .S INDP=+$P(DATA,U,4)
-        .S INTP=+$P(DATA,U,5)
-        .;Create new patient list
-        .I ITER'="" S LIST=LIST_"/"_ITER
-        .S PATCREAT="Y",PXRMLIST=$$CRLST^PXRMRUL1(LIST,CLASS) Q:'PXRMLIST
-        .;
-        .D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,YEAR,PERIOD,INDP,INTP,ITER)
-        .;Clear ^TMP lists created for rule
-        .D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
-        .;Process reminders and finding rules
-        .;If include deceased patients is true then set the flag so reminders
-        .;will be evaluated for deceased patients.
-        .S PXRMIDOD=$S(INDP:1,1:0)
-        .D REM^PXRMETXR(SUB,PXRMLIST,PXRMSTRT,PXRMSTOP,PARTYPE)
-        ;
-        ;Get the name
-        ;S NAME=$$GETNAME(XNAME)
-        ;Create extract summary entry
-        S FDA(810.3,"+1,",.01)=NAME
-        S FDA(810.3,"+1,",.02)=PXRMSTRT
-        S FDA(810.3,"+1,",.03)=PXRMSTOP
-        S FDA(810.3,"+1,",.06)=$$NOW^XLFDT
-        S FDA(810.3,"+1,",1)=IEN
-        S FDA(810.3,"+1,",2)=PARTYPE
-        S FDA(810.3,"+1,",3)=$E(PERIOD,2,99)
-        S FDA(810.3,"+1,",4)=YEAR
-        S FDA(810.3,"+1,",5)=$S(MODE<2:"A",1:"M")
-        S FDA(810.3,"+1,",7)=$E(PERIOD)
-        I PURGE="Y" S FDA(810.3,"+1,",50)=1
-        S FDA(810.3,"+1,",100)=CLASS
-        D UPDATE^DIE("","FDA","FDAIEN","MSG")
-        I $D(MSG) D AWRITE^PXRMUTIL("MSG") G EXIT
-        ;
-        ;Update extract summary from ^TMP
-        D UPDEX(FDAIEN(1))
-        ;
-        ;Transmit results
-        I (MODE=0)!(MODE=2) D TRANS(FDAIEN(1))
-        ;
-        ;Update extract parameters
-        I MODE<2 D UPDPAR
-        ;
-        ;Mail message that extract completed
-        D MAIL(NAME,NEXT,MODE)
-        ;
-EXIT    ;Clear workfile
-        K ^TMP("PXRMETX",$J),^TMP("PXRMETX1",$J)
-        Q
-        ;
-TRANS(PXRMXIEN) ;Transmit HL7 messages
-        N HL7ID,NAME,NEXT
-        S HL7ID=""
-        D HL7^PXRM7API(PXRMXIEN,1,.HL7ID)
-        H 2
-        ;Lock extract summary
-        D LOCK(PXRMXIEN) Q:$D(DUOUT)
-        ;Update run information
-        S NAME=$P($G(^PXRMXT(810.3,PXRMXIEN,0)),U)
-        S NEXT=$P($G(^PXRMXT(810.3,PXRMXIEN,4)),U,3)
-        S FDA(810.3,"?1,",.01)=NAME
-        S FDA(810.36,"?+2,?1,",.01)=HL7ID
-        S FDA(810.36,"?+2,?1,",.02)=$$NOW^XLFDT
-        D UPDATE^DIE("","FDA","","MSG")
-        ;Unlock extract summary
-        D UNLOCK(PXRMXIEN)
-        Q
-        ;
-UPDEX(IEN)      ;Update extract summary
-        N DUOUT
-        ;Lock extract summary
-        D LOCK(IEN) Q:$D(DUOUT)
-        ;
-        ;Update totals section
-        N APPL,CNT,DFN,DUE,DATA,ETYP,EVAL
-        N FAPPL,FCNT,FDATA,FDUE,FEVAL,FGNAM,FGSTA,FIND,FNAPPL,FNDUE,FSEQ
-        N GDATA,GSEQ,INST,NAPPL,NDUE,PCNT,PXRMLIST,RCNT,RIEN,RSEQ,SEQ,TEMP
-        S SEQ="",CNT=1,RSEQ=0
-        F  S SEQ=$O(^TMP("PXRMETX",$J,SEQ)) Q:SEQ=""  D
-        .S INST=0
-        .F  S INST=$O(^TMP("PXRMETX",$J,SEQ,INST)) Q:'INST  D
-        ..S RCNT=""
-        ..F  S RCNT=$O(^TMP("PXRMETX",$J,SEQ,INST,RCNT)) Q:RCNT=""  D
-        ...S DATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT)) Q:'DATA
-        ...S RIEN=$P(DATA,U,1),EVAL=$P(DATA,U,2),APPL=$P(DATA,U,3)
-        ...S NAPPL=$P(DATA,U,4),DUE=$P(DATA,U,5),NDUE=$P(DATA,U,6)
-        ...S PXRMLIST=$P(DATA,U,7)
-        ...S CNT=CNT+1,RSEQ=RSEQ+1
-        ...S TEMP=$$RJ^XLFSTR(RSEQ,3,0)_U_RIEN_U_INST_U_PXRMLIST_U_EVAL_U_APPL_U_NAPPL_U_DUE_U_NDUE
-        ...S ^PXRMXT(810.3,IEN,3,RSEQ,0)=TEMP
-        ...S ^PXRMXT(810.3,IEN,3,"B",$P(TEMP,U,1),RSEQ)=""
-        ...;For each count type
-        ...S GSEQ="",FCNT=0
-        ...F  S GSEQ=$O(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ)) Q:GSEQ=""  D
-        ....S GDATA=$G(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ))
-        ....S FGNAM=$P(GDATA,U),ETYP=$P(GDATA,U,2),FGSTA=$P(GDATA,U,3)
-        ....;For each term
-        ....S FSEQ=0
-        ....F  S FSEQ=$O(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)) Q:FSEQ=""  D
-        .....;Get the term ien
-        .....S FIND=$P($G(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)),U),FCNT=FCNT+1
-        .....;Update finding totals
-        .....S FDATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ))
-        .....S FEVAL=$P(FDATA,U,2),FAPPL=$P(FDATA,U,3),FNAPPL=$P(FDATA,U,4)
-        .....S FDUE=$P(FDATA,U,5),FNDUE=$P(FDATA,U,6)
-        .....S TEMP=FSEQ_U_$P(FIND,";")_U_ETYP_U_FEVAL_U_FAPPL_U_FNAPPL_U_FDUE_U_FNDUE_U_FGNAM_U_FGSTA
-        .....S ^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,0)=TEMP
-        .....;
-        .....;AGP REMOVE UNTIL A DECISION CAN BE MADE
-        .....;S DFN=0,PCNT=0
-        .....;F  S DFN=$O(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ,DFN)) Q:DFN'>0  D
-        .....;.S PCNT=PCNT+1,^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,1,PCNT,0)=DFN
-        .....;I PCNT>0 S ^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,1,0)="^810.3316PA"_U_PCNT_U_PCNT
-        ....I FCNT>0 S ^PXRMXT(810.3,IEN,3,RSEQ,1,0)="^810.331I"_U_FCNT_U_FCNT
-        .I RSEQ>0 S ^PXRMXT(810.3,IEN,3,0)="^810.33I"_U_RSEQ_U_RSEQ
-        ;Unlock extract summary
-        D UNLOCK(IEN)
-        Q
-        ;
-        ;File locking
-LOCK(PXRMXIEN)  L +^PXRMXT(810.3,PXRMXIEN):0
-        I '$T W !!?5,"Another user is using this extract summary" S DUOUT=1
-        Q
-        ;
-UNLOCK(PXRMXIEN)        L -^PXRMXT(810.3,PXRMXIEN) Q
-        ;
-UPDPAR  ;Update parameters when run complete
-        N DATA,LAST,NEXT,PERIOD,TYPE,YEAR
-        S DATA=$G(^PXRM(810.2,IEN,0)),NEXT=$P(DATA,U,6),TYPE=$P(DATA,U,3)
-        ;Last run updated
-        S LAST=NEXT
-        ;Calculate next run
-        I TYPE="Y" S NEXT=NEXT+1
-        I "QM"[TYPE D
-        .N NUM
-        .S PERIOD=$P(NEXT,"/",1),YEAR=$P(NEXT,"/",2)
-        .S NUM=$P(PERIOD,TYPE,2)+1
-        .I TYPE="Q",NUM>4 S NUM=1,YEAR=YEAR+1
-        .I TYPE="M",NUM>12 S NUM=1,YEAR=YEAR+1
-        .S NEXT=TYPE_NUM_"/"_YEAR
-        ;Update last and next run fields
-        S $P(^PXRM(810.2,IEN,0),U,4,6)=LAST_U_$$NOW^XLFDT_U_NEXT
-        Q
-        ;
+PXRMETX ; SLC/PJH - Run Extract for QUERI ;1/22/07  21:25
+ ;;2.0;CLINICAL REMINDERS;**4,7**;Feb 04, 2005;Build 14
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+ ;
+AUTO(ID,PURGE) ;Called from option scheduling (#19.2)
+ N IEN,LIST,LUVALUE,MODE,NEXT
+ S LUVALUE(1)=ID
+ D FIND^DIC(810.2,"","","U",.LUVALUE,"","","","","LIST")
+ ;Get ien of extract parameter
+ S IEN=$P(LIST("DILIST",2,1),U,1) Q:'IEN
+ ;Get next extract period
+ S NEXT=$P($G(^PXRM(810.2,IEN,0)),U,6) Q:NEXT=""
+ ;Node is Extract and Transmit
+ S MODE=$S($P($G(^PXRM(810.2,IEN,100)),U)="N":0,1:1)
+ ;Run extract
+ D RUN^PXRMETX(IEN,NEXT,MODE,PURGE)
+ ;Purge Extract Summary
+ D PRGES^PXRMETXU
+ ;Purge Patient Lists
+ D PRGPL^PXRMETXU
+ ;Call the DOQ-IT HL7 generating routine
+ ;D EXTRACT^VEPER7EX(VDATA(810.2,IEN_",",3,"I"),VDATA(810.2,IEN_",",5,"I"))
+ Q
+ ;
+GETNAME(NAME,CLASS) ;Get the extract name.
+ I '$D(^PXRMXT(810.3,"B",NAME)) Q NAME
+ N CNT,NEW
+ S (CNT,NEW)=0
+ ;If name exists concatenate count
+ F  D  Q:NEW
+ .I '$D(^PXRMXT(810.3,"B",NAME)) S NEW=1 Q
+ .S CNT=CNT+1,NAME=$P(NAME,"/")_"/"_$$RJ^XLFSTR(CNT,2,0)
+ Q NAME
+ ;
+IHD ;Monthly IHD Extract, called from option PXRM EXTRACT VA-IHD QUERI.
+ D AUTO("VA-IHD QUERI","Y")
+ Q
+ ;
+MAIL(NAME,NEXT,MODE) ;Completion mail message
+ N FREQ,TEXT
+ S FREQ="year"
+ I $E(NEXT)="M" S FREQ="month"
+ I $E(NEXT)="Q" S FREQ="quarter"
+ ;
+ I MODE=0 S TEXT="Extract and Transmission"
+ I MODE=1 S TEXT="Extract (No Transmission)"
+ I MODE=2 S TEXT="Manual Extract and Transmission"
+ I MODE=3 S TEXT="Manual Extract (No Transmission)"
+ ;
+ S TEXT=NAME_" "_TEXT_" completed for "_FREQ_" "_NEXT
+ D MES^PXRMEUT(TEXT)
+ Q
+ ;
+MH ;Monthly MH Extract, called from option PXRM EXTRACT VA-MH QUERI.
+ D AUTO("VA-MH QUERI","Y")
+ Q
+ ;
+ACAD ;Auto CAD entry point
+ D AUTO("VOE DOQ-IT CAD EXTRACTION")
+ Q
+ ;
+ADM ;Auto DM entry point
+ D AUTO("VOE DOQ-IT DM EXTRACTION")
+ Q
+ ;
+AHF ;Auto HF entry point
+ D AUTO("VOE DOQ-IT HF EXTRACTION")
+ Q
+ ;
+AHTN ;Auto HTN entry point
+ D AUTO("VOE DOQ-IT HTN EXTRACTION")
+ Q
+ ;
+APC ;Auto PC entry point
+ D AUTO("VOE DOQ-IT PC EXTRACTION")
+ Q
+ ;
+RUN(IEN,NEXT,MODE,PURGE) ;Process extract parameter
+ ; IEN is ien of Extract Parameter
+ ; NEXT is period to extract
+ ; MODE = 0 is extract and transmission
+ ; MODE = 1 is extract only
+ ; MODE = 2 is manual extract and transmission (doesn't update 810.2)
+ ; MODE = 3 is manual extract only (doesn't update 810.2)
+ ;
+ N CLASS,FDA,FDAIEN,MSG
+ N PXRMLIST,PXRMNODE,PXRMRULE,PXRMSTRT,PXRMXIEN,PATCREAT,XNAME
+ ;Initialise
+ K ^TMP("PXRMETX",$J),^TMP("PXRMETX1",$J)
+ ;Workfile node for ^TMP
+ S PXRMNODE="PXRMRULE"
+ ;Get details from parameter file
+ N DATA,INDP,INTP,LIST,NAME,PARTYPE,PERIOD,SNAME,TEXT,YEAR
+ ;Get class from extract parameter
+ S CLASS=$P($G(^PXRM(810.2,IEN,100)),U)
+ ;Otherwise default to local
+ I $G(CLASS)="" S CLASS="L"
+ ;
+ S DATA=$G(^PXRM(810.2,IEN,0))
+ ;Determine Extract Name and period
+ S NAME=$P(DATA,U),PARTYPE=$P(DATA,U,2)
+ S YEAR=$P(NEXT,"/",2),PERIOD=$P(NEXT,"/")
+ ;Calculate report period start and end dates
+ D CALC^PXRMEUT(NEXT,.PXRMSTRT,.PXRMSTOP)
+ ;Determine output name for patient list and extract summary
+ S XNAME=NAME_" "_YEAR_" "_PERIOD
+ ;Process (single) Denominator rule into patient list
+ N SEQ,SUB
+ S SEQ=""
+ F  S SEQ=$O(^PXRM(810.2,IEN,10,"B",SEQ)) Q:'SEQ  D
+ .S SUB=$O(^PXRM(810.2,IEN,10,"B",SEQ,"")) Q:'SUB
+ .S DATA=$G(^PXRM(810.2,IEN,10,SUB,0)) Q:DATA=""
+ .S PXRMRULE=$P(DATA,U,2) Q:'PXRMRULE
+ .S LIST=$P(DATA,U,3) Q:LIST=""
+ .I LIST["yyyy" S LIST=$P(LIST,"yyyy")_YEAR_$P(LIST,"yyyy",2)
+ .I LIST["nn" S LIST=$P(LIST,"nn")_$E(PERIOD,2,10)_$P(LIST,"nn",2)
+ .S INDP=+$P(DATA,U,4)
+ .S INTP=+$P(DATA,U,5)
+ .;Create new patient list
+ .S PATCREAT="Y",PXRMLIST=$$CRLST^PXRMRULE(LIST,CLASS) Q:'PXRMLIST
+ .;
+ .D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,YEAR,PERIOD,INDP,INTP)
+ .;Clear ^TMP lists created for rule
+ .D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
+ .;Process reminders and finding rules
+ .D REM^PXRMETXR(SUB,PXRMLIST,PXRMSTRT,PXRMSTOP,PARTYPE)
+ ;
+ ;Get the name
+ S NAME=$$GETNAME(XNAME)
+ ;Create extract summary entry
+ S FDA(810.3,"+1,",.01)=NAME
+ S FDA(810.3,"+1,",.02)=PXRMSTRT
+ S FDA(810.3,"+1,",.03)=PXRMSTOP
+ S FDA(810.3,"+1,",.06)=$$NOW^XLFDT
+ S FDA(810.3,"+1,",1)=IEN
+ S FDA(810.3,"+1,",2)=PARTYPE
+ S FDA(810.3,"+1,",3)=$E(PERIOD,2,99)
+ S FDA(810.3,"+1,",4)=YEAR
+ S FDA(810.3,"+1,",5)=$S(MODE<2:"A",1:"M")
+ S FDA(810.3,"+1,",7)=$E(PERIOD)
+ I PURGE="Y" S FDA(810.3,"+1,",50)=1
+ S FDA(810.3,"+1,",100)=CLASS
+ D UPDATE^DIE("","FDA","FDAIEN","MSG")
+ I $D(MSG) D AWRITE^PXRMUTIL("MSG") G EXIT
+ ;
+ ;Update extract summary from ^TMP
+ D UPDEX(FDAIEN(1))
+ ;
+ ;Transmit results
+ I (MODE=0)!(MODE=2) D TRANS(FDAIEN(1))
+ ;
+ I $$GET^XPAR("SYS","DOQ-IT")="YES" D EXTRACT^VEPER7EX(VDATA(810.2,IEN_",",3,"I"),VDATA(810.2,IEN_",",5,"I"),PXRMLIST)
+ ;
+ ;Update extract parameters
+ I MODE<2 D UPDPAR
+ ;
+ ;Mail message that extract completed
+ D MAIL(NAME,NEXT,MODE)
+ ;
+EXIT ;Clear workfile
+ K ^TMP("PXRMETX",$J),^TMP("PXRMETX1",$J)
+ Q
+ ;
+TRANS(PXRMXIEN) ;Transmit HL7 messages
+ N HL7ID,NAME,NEXT
+ S HL7ID=""
+ D HL7^PXRM7API(PXRMXIEN,1,.HL7ID)
+ H 2
+ ;Lock extract summary
+ D LOCK(PXRMXIEN) Q:$D(DUOUT)
+ ;Update run information
+ S NAME=$P($G(^PXRMXT(810.3,PXRMXIEN,0)),U)
+ S NEXT=$P($G(^PXRMXT(810.3,PXRMXIEN,4)),U,3)
+ S FDA(810.3,"?1,",.01)=NAME
+ S FDA(810.36,"?+2,?1,",.01)=HL7ID
+ S FDA(810.36,"?+2,?1,",.02)=$$NOW^XLFDT
+ D UPDATE^DIE("","FDA","","MSG")
+ ;Unlock extract summary
+ D UNLOCK(PXRMXIEN)
+ Q
+ ;
+UPDEX(IEN) ;Update extract summary
+ N DUOUT
+ ;Lock extract summary
+ D LOCK(IEN) Q:$D(DUOUT)
+ ;
+ ;Update totals section
+ N APPL,CNT,DFN,DUE,DATA,ETYP,EVAL
+ N FAPPL,FCNT,FDATA,FDUE,FEVAL,FGNAM,FGSTA,FIND,FNAPPL,FNDUE,FSEQ
+ N GDATA,GSEQ,INST,NAPPL,NDUE,PCNT,PXRMLIST,RCNT,RIEN,RSEQ,SEQ,TEMP
+ S SEQ="",CNT=1,RSEQ=0
+ F  S SEQ=$O(^TMP("PXRMETX",$J,SEQ)) Q:SEQ=""  D
+ .S INST=0
+ .F  S INST=$O(^TMP("PXRMETX",$J,SEQ,INST)) Q:'INST  D
+ ..S RCNT=""
+ ..F  S RCNT=$O(^TMP("PXRMETX",$J,SEQ,INST,RCNT)) Q:RCNT=""  D
+ ...S DATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT)) Q:'DATA
+ ...S RIEN=$P(DATA,U,1),EVAL=$P(DATA,U,2),APPL=$P(DATA,U,3)
+ ...S NAPPL=$P(DATA,U,4),DUE=$P(DATA,U,5),NDUE=$P(DATA,U,6)
+ ...S PXRMLIST=$P(DATA,U,7)
+ ...S CNT=CNT+1,RSEQ=RSEQ+1
+ ...S TEMP=$$RJ^XLFSTR(RSEQ,3,0)_U_RIEN_U_INST_U_PXRMLIST_U_EVAL_U_APPL_U_NAPPL_U_DUE_U_NDUE
+ ...S ^PXRMXT(810.3,IEN,3,RSEQ,0)=TEMP
+ ...S ^PXRMXT(810.3,IEN,3,"B",$P(TEMP,U,1),RSEQ)=""
+ ...;For each count type
+ ...S GSEQ="",FCNT=0
+ ...F  S GSEQ=$O(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ)) Q:GSEQ=""  D
+ ....S GDATA=$G(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ))
+ ....S FGNAM=$P(GDATA,U),ETYP=$P(GDATA,U,2),FGSTA=$P(GDATA,U,3)
+ ....;For each term
+ ....S FSEQ=0
+ ....F  S FSEQ=$O(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)) Q:FSEQ=""  D
+ .....;Get the term ien
+ .....S FIND=$P($G(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)),U),FCNT=FCNT+1
+ .....;Update finding totals
+ .....S FDATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ))
+ .....S FEVAL=$P(FDATA,U,2),FAPPL=$P(FDATA,U,3),FNAPPL=$P(FDATA,U,4)
+ .....S FDUE=$P(FDATA,U,5),FNDUE=$P(FDATA,U,6)
+ .....S TEMP=FSEQ_U_$P(FIND,";")_U_ETYP_U_FEVAL_U_FAPPL_U_FNAPPL_U_FDUE_U_FNDUE_U_FGNAM_U_FGSTA
+ .....S ^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,0)=TEMP
+ .....;
+ .....;AGP REMOVE UNTIL A DECISION CAN BE MADE
+ .....;S DFN=0,PCNT=0
+ .....;F  S DFN=$O(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ,DFN)) Q:DFN'>0  D
+ .....;.S PCNT=PCNT+1,^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,1,PCNT,0)=DFN
+ .....;I PCNT>0 S ^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,1,0)="^810.3316PA"_U_PCNT_U_PCNT
+ ....I FCNT>0 S ^PXRMXT(810.3,IEN,3,RSEQ,1,0)="^810.331I"_U_FCNT_U_FCNT
+ .I RSEQ>0 S ^PXRMXT(810.3,IEN,3,0)="^810.33I"_U_RSEQ_U_RSEQ
+ ;Unlock extract summary
+ D UNLOCK(IEN)
+ Q
+ ;
+ ;File locking
+LOCK(PXRMXIEN) L +^PXRMXT(810.3,PXRMXIEN):0
+ I '$T W !!?5,"Another user is using this extract summary" S DUOUT=1
+ Q
+ ;
+UNLOCK(PXRMXIEN) L -^PXRMXT(810.3,PXRMXIEN) Q
+ ;
+UPDPAR ;Update parameters when run complete
+ N DATA,LAST,NEXT,PERIOD,TYPE,YEAR
+ S DATA=$G(^PXRM(810.2,IEN,0)),NEXT=$P(DATA,U,6),TYPE=$P(DATA,U,3)
+ ;Last run updated
+ S LAST=NEXT
+ ;Calculate next run
+ I TYPE="Y" S NEXT=NEXT+1
+ I "QM"[TYPE D
+ .N NUM
+ .S PERIOD=$P(NEXT,"/",1),YEAR=$P(NEXT,"/",2)
+ .S NUM=$P(PERIOD,TYPE,2)+1
+ .I TYPE="Q",NUM>4 S NUM=1,YEAR=YEAR+1
+ .I TYPE="M",NUM>12 S NUM=1,YEAR=YEAR+1
+ .S NEXT=TYPE_NUM_"/"_YEAR
+ ;Update last and next run fields
+ S $P(^PXRM(810.2,IEN,0),U,4,6)=LAST_U_$$NOW^XLFDT_U_NEXT
+ Q
+ ;