PXRMRUL1 ; SLC/AGP,PKR - Patient list routines. ; 03/29/2007
 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
 ; 
 ;
ASK(PLIEN,OPT) ;Verify patient list name
 N X,Y,TEXT
 K DIROUT,DIRUT,DTOUT,DUOUT
 S DIR(0)="YA0"
 S DIR("A")=OPT_" patient list "_$P($G(^PXRMXP(810.5,PLIEN,0)),U)_"?: "
 S DIR("B")="N"
 S DIR("?")="Enter Y or N. For detailed help type ??"
 W !
 D ^DIR K DIR
 I $D(DIROUT) S DTOUT=1
 I $D(DTOUT)!($D(DUOUT)) Q
 I $E(Y(0))="N" S DUOUT=1 Q
 Q
 ;
COPY(IENO) ;Copy patient list
 ;Check if OK to copy
 D ASK(IENO,"Copy") Q:$D(DUOUT)!$D(DTOUT)
 N FDA,IENN,IND,MSG,NNAME,ODATA,OEPIEN,ONAME,ORULE,PATCREAT,TEXT,X,Y
 ;Select list to copy to
 S TEXT="Select PATIENT LIST name to copy to: "
 D PLIST^PXRMLCR(.IENN,TEXT,IENO) Q:$D(DUOUT)!$D(DTOUT)  Q:'IENN
 S NNAME=$P($G(^PXRMXP(810.5,IENN,0)),U)
 ;
 ;Get original Patient List record 
 S ODATA=$G(^PXRMXP(810.5,IENO,0))
 S ONAME=$P(ODATA,U),OEPIEN=$P(ODATA,U,5),ORULE=$P(ODATA,U,6)
 ;
 M ^PXRMXP(810.5,IENN)=^PXRMXP(810.5,IENO)
 D ASK^PXRMXD(.PATCREAT,"Secure list?: ",2)
 ;Update header info
 S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")
 S IND=IENN_","
 S FDA(810.5,IND,.01)=NNAME
 S FDA(810.5,IND,.04)=$$NOW^XLFDT
 S FDA(810.5,IND,.05)=OEPIEN
 S FDA(810.5,IND,.06)=ORULE
 S FDA(810.5,IND,.07)=$G(DUZ)
 S FDA(810.5,IND,.08)=TYPE
 D UPDATE^DIE("","FDA","","MSG")
 ;Error
 I $D(MSG) D ERR
 ;
 W !!,"Completed copy of '"_ONAME_"'"
 W !,"into '"_NNAME_"'",! H 2
 K ^TMP($J,"PXRMRULE")
 Q
 ;
CRLST(NAME,CLASS) ;Create new patient list
 N IEN
 ;Check if name exists
 S IEN=$O(^PXRMXP(810.5,"B",NAME,"")) I IEN Q IEN
 ;Otherwise create national entry
 N FDA,FDAIEN,MSG
 S FDA(810.5,"+1,",.01)=NAME
 S FDA(810.5,"+1,",100)=CLASS
 S FDA(810.5,"+1,",.07)=$G(DUZ)
 ;Make stub public
 S FDA(810.5,"+1,",.08)="PUB"
 D UPDATE^DIE("","FDA","FDAIEN","MSG")
 ;Error
 I $D(MSG) Q 0
 ;Otherwise list ien
 Q FDAIEN(1)
 ;
COUNT(NODE) ;Count the number of entries.
 N DFN,NUM
 S (DFN,NUM)=0
 F  S DFN=$O(^TMP($J,NODE,DFN)) Q:DFN=""  S NUM=NUM+1
 Q NUM
 ;
DELETE(LIST) ;Delete Patient list
 I '$$VEDIT^PXRMUTIL("^PXRMXP(810.5,",LIST) D  Q
 .W !!,?5,"VA- and national class patient lists may not be deleted" H 2
 .S DUOUT=1
 ;Check if this is the right list
 D ASK(LIST,"Delete") Q:$D(DUOUT)!$D(DTOUT)
 ;
 N DA,DIK,DUOUT
 ;Lock patient list
 D LOCK Q:$D(DUOUT)
 ;Kill List
 S DA=LIST,DIK="^PXRMXP(810.5,"
 D ^DIK
 ;Unlock patient list
 D UNLOCK
 Q
 ;
DATECHK(DATE) ;
 I DATE=0 Q 1
 S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
 Q $$VDT^PXRMINTR(DATE)
 ;
DATES(LBBDT,LBEDT,RBDT,REDT,FARR) ;Set the dates in the finding array to
 ;FileMan dates.
 N FI,PXRMDATE,TBDT,TEDT
 S FI=0
 F  S FI=+$O(FARR(20,FI)) Q:FI=0  D
 . S TBDT=$P(FARR(20,FI,0),U,8),TEDT=$P(FARR(20,FI,0),U,11)
 . I TBDT="",TEDT="" D
 .. S $P(FARR(20,FI,0),U,8)=RBDT,$P(FARR(20,FI,0),U,11)=REDT
 . E  D
 .. S PXRMDATE=$S(TBDT["BDT":LBBDT,1:LBEDT)
 .. S TBDT=$S(TBDT="":0,TBDT=0:0,TBDT="BDT":LBBDT,1:$$CTFMD^PXRMDATE(TBDT))
 .. S PXRMDATE=$S(TEDT["BDT":LBBDT,1:LBEDT)
 .. S TEDT=$S(TEDT="":"T",TEDT=0:"T",TEDT="BDT":LBBDT,1:TEDT)
 .. S TEDT=$$CTFMD^PXRMDATE(TEDT)
 .. S $P(FARR(20,FI,0),U,8)=TBDT,$P(FARR(20,FI,0),U,11)=TEDT
 Q
 ;
ERR ;Error Handler
 N ERROR,IC,REF
 S ERROR(1)="Unable to build patient list : "
 S ERROR(2)=NAME
 S ERROR(3)="Error in UPDATE^DIE, needs further investigation"
 ; Move MSG into Error
 S REF="MSG"
 F IC=4:1 S REF=$Q(@REF) Q:REF=""  S ERROR(IC)=REF_"="_@REF
 ;Screen message
 D EN^DDIOL(.ERROR)
 Q
 ;
INSERT(FROUT,DFN,TNAME,TFIEV,RSTOP) ;Save patient data.
 I TFIEV(1)=0 Q
 N DATA,DONE,IND,LEN,REF,ROOT,START,SUB,TEMP
 S REF="TFIEV(1,""CSUB"")"
 S PROOT=$P(REF,")",1)
 ;Build the root so we can tell when we are done.
 S TEMP=$NA(@REF)
 S ROOT=$P(TEMP,")",1)
 S REF=$Q(@REF)
 I REF'[ROOT Q
 S DONE=0
 F  Q:(REF="")!(DONE)  D
 . S START=$F(REF,ROOT)
 . S LEN=$L(REF)-1
 . S IND=$E(REF,START,LEN)
 . S DATA(TNAME_IND)=@REF
 . S REF=$Q(@REF)
 . I REF'[ROOT S DONE=1
 I $D(DATA) M ^TMP($J,FROUT,DFN,"DATA")=DATA
 Q
 ;
INST(DFN) ;Get the PCMM Institution.
 N DATE,INST
 ;Check PCMM
 S DATE=$S($G(PXRMDATE)'="":$P(PXRMDATE,"."),1:DT)
 ;DBIA #1916
 S INST=$P($$INSTPCTM^SCAPMC(DFN,DATE),U,3,4)
 Q INST
 ;
LOCK L +^PXRMXP(810.5,LIST):0
 E  W !!?5,"Another user is using this patient list" S DUOUT=1
 Q
 ;
LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical
 ;operator LOGOP to generate a new list and return it in LIST1
 N DFN1,DFN2
 I LOGOP="&" D  Q
 . S DFN1=""
 . F  S DFN1=$O(^TMP($J,LIST1,DFN1)) Q:DFN1=""  D
 .. I $D(^TMP($J,LIST2,DFN1)) M ^TMP($J,LIST1,DFN1)=^TMP($J,LIST2,DFN1) Q
 .. K ^TMP($J,LIST1,DFN1)
 ;
 ;"~" represents "&'".
 I LOGOP="~" D  Q
 . S DFN1=""
 . F  S DFN1=$O(^TMP($J,LIST1,DFN1)) Q:DFN1=""  D
 .. I $D(^TMP($J,LIST2,DFN1)) K ^TMP($J,LIST1,DFN1)
 ;
 I LOGOP="!" D
 . S DFN2=""
 . F  S DFN2=$O(^TMP($J,LIST2,DFN2)) Q:DFN2=""  D
 .. M ^TMP($J,LIST1,DFN2)=^TMP($J,LIST2,DFN2)
 Q
 ;
REM(FRACT,RIEN,LBBDT,LBEDT,RSTART,RSTOP,PNODE) ;Process reminder finding rule
 N DEFFARR,PXRMDATE
 D DEF^PXRMLDR(RIEN,.DEFARR)
 D DATES(LBBDT,LBEDT,RSTART,RSTOP,.DEFARR)
 S PXRMDATE=RSTOP
 D BLDPLST^PXRMPLST(.DEFARR,PNODE,1)
 ;Remove, Select or Add Findings operations
 I FRACT="A" D LOGOP(FROUT,PNODE,"!") Q
 I FRACT="D" D LOGOP(FROUT,PNODE,"~") Q
 I FRACT="S" D LOGOP(FROUT,PNODE,"&") Q
 Q
 ;
TERM(FRACT,FRTIEN,LBBDT,LBEDT,RSTART,RSTOP,PNODE,INST) ;Process TERM finding
 ;rules
 N FINDPA,FINDING,FNAME,PLIST,PXRMDATE,PXRMDEBG
 N TERMARR,TFIEV,TNAME
 ;Get term definition array
 D TERM^PXRMLDR(FRTIEN,.TERMARR)
 S TNAME=$P(TERMARR(0),U,1)
 S INST=$S(FRACT'="F":0,TNAME="VA-PCMM INSTITUTION":1,TNAME="VA-IHD STATION CODE":1,1:0)
 ;Set begin and end dates in the term.
 D DATES(LBBDT,LBEDT,RSTART,RSTOP,.TERMARR)
 S $P(FINDPA(0),U,8)=RSTART,$P(FINDPA(0),U,11)=RSTOP,PXRMDATE=RSTOP
 ;
 ;Add operation
 I FRACT="A" D  Q
 .;Process term for date range
 .D EVALPL^PXRMTERL(.FINDPA,.TERMARR,PNODE)
 .;Merge lists if operation is add
 .M ^TMP($J,FROUT)=^TMP($J,PNODE,1)
 ;Remove, Select or Insert Findings operations
 I FRACT="F" S PXRMDEBG=1
 S DFN=0
 F  S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN  D
 .I INST S ^TMP($J,FROUT,DFN,"INST")=$$INST(DFN) Q
 .;Evaluate term
 .K TFIEV D IEVALTER^PXRMTERM(DFN,.FINDPA,.TERMARR,1,.TFIEV)
 .;Delete any ^TMP patient in PLIST if action is remove
 .I FRACT="R",TFIEV(1) K ^TMP($J,FROUT,DFN) Q
 .;Delete any ^TMP patient not in PLIST if action is select
 .I FRACT="S",'TFIEV(1) K ^TMP($J,FROUT,DFN) Q
 .I FRACT="F",TFIEV(1) D
 .. S FINDING=TFIEV(1,"FINDING")
 .. I '$D(FNAME(FINDING)) S FNAME(FINDING)=$$GETFNAME^PXRMDATA(FINDING)
 .. S TFIEV(1,"CSUB","FINDING NAME")=FNAME(FINDING)
 .. D INSERT(FROUT,DFN,TNAME,.TFIEV,RSTOP)
 Q
 ;
UNLOCK L -^PXRMXP(810.5,LIST) Q
 ;