Routine: PXRMGEVA

PXRMGEVA ;SLC/AGP,RFR - Generic entry point to run different Reminder Evaluation ;Jan 13, 2023@17:06

 ;;2.0;CLINICAL REMINDERS;**45,71,84**;Feb 04, 2005;Build 2

 ; Reference to OIS^ORX8 in ICR #2467

 ; Reference to EN^ORQ1 in ICR #3154

 ; Reference to EN^ORX8 in ICR #871

 ; Reference to PKGID^ORX8 in ICR #3071

 ; Reference to VALUE^ORX8 in ICR #2467

 ; Reference to ^ORD(100.98,"B", in ICR #873

ERROR(RESULT,MSG) ;

 S @RESULT@(0)=-1_U_MSG

FINDDGS(RESULT,INPUT) ;

 N FAIL,IEN,NAME

 S NAME="",FAIL=0 F  S NAME=$O(INPUT("ROC DISPLAY GROUPS",NAME)) Q:NAME=""!(FAIL>0)  D

 .S IEN=$O(^ORD(100.98,"B",NAME,"")) I IEN'>0 D ERROR(.RESULT,"Could not find Display Group: "_NAME) S FAIL=1

 .S INPUT("DG IEN",IEN)=""

 .S INPUT("DG IEN",IEN,"START")=+$G(INPUT("ROC DISPLAY GROUPS",NAME,"START"))

 .S INPUT("DG IEN",IEN,"STOP")=+$G(INPUT("ROC DISPLAY GROUPS",NAME,"STOP"))

GETOIS(INPUT) ; find orderable items for each order

 N CNT,NUM,ARRAY,OI,ORDIEN,POS,PXRMOIS

 S ORDIEN=0 F  S ORDIEN=$O(INPUT("ROC ORDERS",ORDIEN)) Q:ORDIEN'>0  D

 .K PXRMOIS D OIS^ORX8(.PXRMOIS,ORDIEN) I '$D(PXRMOIS) Q

 .M INPUT("ROC ORDERS",ORDIEN,"OI")=PXRMOIS

GTORDERS(INPUT) ;

 N DIEN,DATE,END,NODE,PAT,ORDIEN,ORN,PXRMOIS,START,STOP,ORLIST,MOD,PXRMINST,ORUPCHUK

 S PAT=$G(INPUT("DFN"))

 S DIEN=0 F  S DIEN=$O(INPUT("DG IEN",DIEN)) Q:DIEN'>0  D

 .K ^TMP("ORR",$J)

 .S START=$S(INPUT("DG IEN",DIEN,"START")>0:INPUT("DG IEN",DIEN,"START"),1:$G(INPUT("ROC START")))

 .S STOP=$S(INPUT("DG IEN",DIEN,"STOP")>0:INPUT("DG IEN",DIEN,"STOP"),1:$G(INPUT("ROC STOP")))

 .;call for current activities

 .D EN^ORQ1(PAT_";DPT(",DIEN,1,,START,STOP,1)

 .S DATE="" F  S DATE=$O(^TMP("ORR",$J,DATE)) Q:DATE=""  D

 ..F ORN=1:1:$G(^TMP("ORR",$J,DATE,"TOT"))  D

 ...S NODE=$G(^TMP("ORR",$J,DATE,ORN))

 ...I $D(INPUT("ROC ORDERS",+$P(NODE,U))) Q

 ...I ('$D(INPUT("ROC STATUS","*"))&('$D(INPUT("ROC STATUS",$P(NODE,U,6))))) Q

 ...I $D(INPUT("ROC ORDERED WITHIN"))&(($P(NODE,U,3)<START)!($P(NODE,U,3)>STOP)) Q

 ...S ORDIEN=+$P(NODE,U)

 ...D EN^ORX8(ORDIEN)

 ...S NODE=NODE_U_$P(ORUPCHUK("ORNP"),U)

 ...K ORUPCHUK

 ...S INPUT("ROC ORDERS",ORDIEN)=NODE

 ...M INPUT("ROC ORDERS",ORDIEN,"TX")=^TMP("ORR",$J,DATE,ORN,"TX")

 ...S INPUT("ROC ORDERS",ORDIEN,"PKG ID")=$$PKGID^ORX8(ORDIEN)

 ...F PXRMINST=1:1  S MOD=$$VALUE^ORX8(ORDIEN,"MODIFIER",PXRMINST,"E") Q:MOD=""  D

 ....S INPUT("ROC ORDERS",ORDIEN,"MODIFIERS",PXRMINST)=MOD

 ...K PXRMOIS D OIS^ORX8(.PXRMOIS,ORDIEN)

 ...I $D(PXRMOIS) M INPUT("ROC ORDERS",ORDIEN,"OI")=PXRMOIS

 K ^TMP("ORR",$J)

GETVAL(INPUT,TYPE) ;

 Q $G(INPUT("VARIABLES",TYPE))

REM(RESULT,INPUT) ; controller for reminder evaluation types

 I $D(INPUT("LR")) D REMLIST(.RESULT,.INPUT) Q

 I $D(INPUT("REMINDERS")) D REMEVAL(.RESULT,.INPUT) Q

 D REMOC(.RESULT,.INPUT)

REMMDEF(INPUT,DEFARR) ; update DEFARR with modifiers

 N ITEM,NUM,SUB,PIECE,TEMP,VALUE

 S NUM=0 F  S NUM=$O(DEFARR(20,NUM)) Q:NUM'>0  D

 .S ITEM=$P($G(DEFARR(20,NUM,0)),U) I ITEM="" Q

 .I '$D(INPUT("EVAL","FINDINGS",ITEM)) Q

 .S SUB="" F  S SUB=$O(INPUT("EVAL","FINDINGS",ITEM,SUB)) Q:SUB=""  D

 ..S PIECE=0 F  S PIECE=$O(INPUT("EVAL","FINDINGS",ITEM,SUB,PIECE)) Q:PIECE'>0  D

 ...S VALUE=$G(INPUT("EVAL","FINDINGS",ITEM,SUB,PIECE)) I VALUE="" Q

 ...I VALUE["$$" S TEMP="S VALUE="_VALUE X TEMP

 ...S $P(DEFARR(20,NUM,SUB),U,PIECE)=VALUE

 I $G(INPUT("EVAL","EVAL DATE"))["$$" D  Q

 .S TEMP="S VALUE="_INPUT("EVAL","EVAL DATE") X TEMP

 .S INPUT("EVAL","NEW EVAL DATE")=VALUE

REMEVAL(RESULT,INPUT) ;

 N RIEN,FIEVAL,TODAY,OUTTYPE,PNAME,ONAME,PXRMSRCFF

 S PXRMSRCFF=1

 K ^TMP("PXRHM",$J)

 S RIEN=0 F  S RIEN=$O(INPUT("REMINDERS",RIEN)) Q:'+RIEN  D

 .S ONAME=$P(INPUT("REMINDERS",RIEN),U),FIEVAL=$P(INPUT("REMINDERS",RIEN),U,2)

 .S OUTTYPE=+$P(INPUT("REMINDERS",RIEN),U,3),TODAY=+$P(INPUT("REMINDERS",RIEN),U,4)

 .D MAINDF(INPUT("DFN"),RIEN,OUTTYPE,TODAY,FIEVAL)

 .S PNAME=$P($G(^PXD(811.9,RIEN,0)),U,3)

 .I PNAME="" S PNAME=$P($G(^PXD(811.9,RIEN,0)),U)

 .S @RESULT@(ONAME)=$G(^TMP("PXRHM",$J,RIEN,PNAME))

 .S @RESULT@(ONAME,"PRINT NAME")=PNAME

 .I FIEVAL M @RESULT@(ONAME,"FIEVAL")=^TMP("PXRHM",$J,RIEN,"FIEVAL")

 .I OUTTYPE>0 M @RESULT@(ONAME,"MAINTENANCE")=^TMP("PXRHM",$J,RIEN,PNAME,"TXT")

 .K ^TMP("PXRHM",$J)

 .I $D(^TMP("PXRM BL DATA",$J)) D

 ..S RIEN("C")=$G(^TMP("PXRM BL DATA",$J,"REMINDER IEN"))

 ..S PNAME=$G(^TMP("PXRM BL DATA",$J,"REMINDER NAME"))

 ..I RIEN("C")=""!(PNAME="") Q

 ..S @RESULT@(ONAME,"FINDINGS",PNAME)=$G(^TMP("PXRM BL DATA",$J,"PXRHM",RIEN("C"),PNAME))

 ..I FIEVAL M @RESULT@(ONAME,"FINDINGS",PNAME,"FIEVAL")=^TMP("PXRM BL DATA",$J,"FIEVAL")

 ..I OUTTYPE>0 M @RESULT@(ONAME,"FINDINGS",PNAME,"MAINTENANCE")=^TMP("PXRM BL DATA",$J,"PXRHM",RIEN("C"),PNAME,"TXT")

 ..K ^TMP("PXRM BL DATA",$J)

MAINDF(DFN,PXRMITEM,OUTTYPE,EVALDT,SAVEFIE) ;

 N DEFARR,FIEVAL,REMCFIEN,MESSAGE,FINDING

 D DEF^PXRMLDR(PXRMITEM,.DEFARR)

 I OUTTYPE>0 D

 .S REMCFIEN=+$O(^PXRMD(811.4,"B","VA-REMINDER DEFINITION","")) Q:REMCFIEN<1

 .S FINDING=0 F  S FINDING=+$O(DEFARR("E","PXRMD(811.4,",REMCFIEN,FINDING)) Q:'+FINDING  S $P(DEFARR(20,FINDING,15),U,4)=OUTTYPE

 I $G(EVALDT)?7N S SAVEFIE=1 ;MAINDF^PXRM, which allows passing evaluation date, always saved the FIEVAL array

 E  S EVALDT=$$NOW^XLFDT

 D EVAL^PXRM(DFN,.DEFARR,OUTTYPE,0,.FIEVAL,EVALDT)

 I $G(SAVEFIE) M ^TMP("PXRHM",$J,PXRMITEM,"FIEVAL")=FIEVAL

REMLIST(RESULT,INPUT) ;

 N BEG,END,CNT,DATA,DATANAM,DATAVAL,FAIL,INC,LIEN,LNAME,NODE,NUM,OVER,PAT,PFNAME,PNAME,PLIST,PATCREAT,RETDATA,SECURE

 S LNAME="",FAIL=0 F  S LNAME=$O(INPUT("LR",LNAME)) Q:LNAME=""!(FAIL=1)  D

 .K BEG,END,LIEN,PFNAME,PNAME,PLIST,SECURE,OVER,RETDATA

 .S LIEN=+$O(^PXRM(810.4,"B",LNAME,"")) I LIEN'>0 D ERROR(.RESULT,"List Rule: "_LNAME_" not found") S FAIL=1 Q

 .S NODE=$G(INPUT("LR",LNAME)),PNAME=$P(NODE,U),BEG=$P(NODE,U,2),END=$P(NODE,U,3),SECURE=$P(NODE,U,4),OVER=$P(NODE,U,5),RETDATA=+$P(NODE,U,6)

 .S PLIST=$$REMPLCRE(PNAME,SECURE,OVER) I +PLIST'>0 D ERROR(.RESULT,"Error could not find or create patient list "_PLNAME) S FAIL=1 Q

 .S PFNAME=$P(PLIST,U,2)

 .D RUN^PXRMLCR(LIEN,+PLIST,"PXRMRULE",BEG,END,0,1)

 .I '$D(^PXRMXP(810.5,+PLIST,30)) Q

 .S NUM=0 F  S NUM=$O(^PXRMXP(810.5,+PLIST,30,NUM)) Q:NUM'>0  D

 ..S PAT=$P($G(^PXRMXP(810.5,+PLIST,30,NUM,0)),U) I PAT="" Q

 ..S @RESULT@(LNAME,PAT)=""

 ..I RETDATA=0 Q

 ..S CNT=0 F  S CNT=$O(^PXRMXP(810.5,+PLIST,30,NUM,"DATA",CNT)) Q:CNT'>0  D

 ...S DATA=$G(^PXRMXP(810.5,+PLIST,30,NUM,"DATA",CNT,0)) I DATA="" Q

 ...S DATANAM=$P($P(DATA,U),",",2),DATAVAL=$P(DATA,U,2) I DATANAM="" Q

 ...S @RESULT@(LNAME,PAT,"DATA",DATANAM)=DATAVAL

 .S @RESULT@(LNAME,"PATIENT LIST CREATED")=PFNAME

 .S @RESULT@(0)=1

REMPLCRE(PLNAME,SECURE,OVER) ;

 N FDA,IENS,NAME,NUM,RESULT,UNIQUE

 S (NUM,RESULT,UNIQUE)=0

 ;if overwrite check to see if the list exist

 I OVER=1 S RESULT=$O(^PXRMXP(810.5,"B",PLNAME,""))

 I RESULT>0 Q RESULT

 S NAME=PLNAME

 ;if not overwrite find unique and name exist create unique name

 I OVER=0,$D(^PXRMXP(810.5,"B",NAME))>0 D

 .F  Q:UNIQUE=1  D

 ..S NAME=PLNAME_" ("_$$NOW^XLFDT()_")"

 ..I $D(^PXRMXP(810.5,"B",NAME))=0 S UNIQUE=1 Q

 ..H 1

 ;create stub in 810.5

 S IENS="?+1,"

 S FDA(810.5,IENS,.01)=NAME,FDA(810.5,IENS,100)="L",FDA(810.5,IENS,.07)=DUZ,FDA(810.5,IENS,.08)=$S(SECURE=0:"PUB",1:"PVT")

 D UPDATE^DIE("","FDA","","MSG")

 ;if error display message and quit

 I $D(MSG) Q 0

 S RESULT=$O(^PXRMXP(810.5,"B",NAME,""))

 Q RESULT_U_NAME

REMOC(RESULT,INPUT) ; controller for reminder order checks

 N DISPLAY,FOUND,GROUPS,NUM,OI,OINAME,ORDIEN,PAT,PNAME,SEV,STATUS,RNAME,RIEN,GNAME,OIGROUPS

 I '$D(INPUT("ROC","ALL")) M GROUPS=INPUT("ROC")

 I '$D(INPUT("ROC ORDERS")) Q

 S PAT=$G(INPUT("DFN"))

 S STATUS=0

 ;loop through orders

 S ORDIEN=0,FOUND=0 F  S ORDIEN=$O(INPUT("ROC ORDERS",ORDIEN)) Q:ORDIEN'>0  D

 .;loop through orderable items for each order

 .S OI=0 F  S OI=$O(INPUT("ROC ORDERS",ORDIEN,"OI",OI)) Q:OI'>0  D

 ..S OINAME=$P($G(INPUT("ROC ORDERS",ORDIEN,"OI",OI)),U)

 ..I $D(INPUT("ROC RETURN TYPE","GROUPS")) D

 ...D GETGRPS^PXRMORCH(OI,.OIGROUPS) Q:'$D(OIGROUPS)

 ...S @RESULT@(0)=1

 ...M @RESULT@(ORDIEN,"GROUPS")=OIGROUPS

 ..;does not process reminder order checks

 ..I '$D(INPUT("ROC RETURN TYPE","RULES")) Q

 ..;Process OI against all Production Reminder Order checks Rule

 ..I '$D(GROUPS) D ORDERCHK^PXRMORCH(PAT,OI,STATUS,0,0)

 ..;Process OI against Production Reminder Order Checks only found in the array of groups

 ..I $D(GROUPS) D ORDERGRP^PXRMORCH(PAT,OI,STATUS,0,.GROUPS)

 ..;quit if no order checks found

 ..I '$D(^TMP($J,OI)) Q

 ..S @RESULT@(0)=1

 ..S SEV=0 F  S SEV=$O(^TMP($J,OI,SEV)) Q:SEV'>0  D

 ...S DISPLAY="" F  S DISPLAY=$O(^TMP($J,OI,SEV,DISPLAY)) Q:DISPLAY=""  D

 ....S RIEN=$O(^PXD(801.1,"D",DISPLAY,0)) I RIEN>0 S RNAME=$P($G(^PXD(801.1,RIEN,0)),U)

 ....I RNAME="" S RNAME=DISPLAY

 ....S @RESULT@(ORDIEN,"RULES",RNAME)=""

 ..K ^TMP($J,OI)

 .I '(($D(@RESULT@(ORDIEN,"RULES")))!($D(@RESULT@(ORDIEN,"GROUPS")))) Q

 .S @RESULT@(ORDIEN)=$G(INPUT("ROC ORDERS",ORDIEN))

 .M @RESULT@(ORDIEN,"TX")=INPUT("ROC ORDERS",ORDIEN,"TX")

 .I $D(INPUT("ROC RETURN TYPE","OI")) M @RESULT@(ORDIEN,"OI")=INPUT("ROC ORDERS",ORDIEN,"OI")

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMGEVA   9229     printed  Mar 13, 2025@20:50:40                                                                                                                                                                                                    Page 2

PXRMGEVA  ;SLC/AGP,RFR - Generic entry point to run different Reminder Evaluation ;Jan 13, 2023@17:06

 +1       ;;2.0;CLINICAL REMINDERS;**45,71,84**;Feb 04, 2005;Build 2

 +2       ;

 +3       ; Reference to OIS^ORX8 in ICR #2467

 +4       ; Reference to EN^ORQ1 in ICR #3154

 +5       ; Reference to EN^ORX8 in ICR #871

 +6       ; Reference to PKGID^ORX8 in ICR #3071

 +7       ; Reference to VALUE^ORX8 in ICR #2467

 +8       ; Reference to ^ORD(100.98,"B", in ICR #873

 +9       ;

ERROR(RESULT,MSG) ;

 +1        SET @RESULT@(0)=-1_U_MSG

 +2        QUIT

 +3       ;

FINDDGS(RESULT,INPUT) ;

 +1        NEW FAIL,IEN,NAME

 +2        SET NAME=""

           SET FAIL=0

FOR

               SET NAME=$ORDER(INPUT("ROC DISPLAY GROUPS",NAME))

               if NAME=""!(FAIL>0)

                   QUIT

               Begin DoDot:1

 +3                SET IEN=$ORDER(^ORD(100.98,"B",NAME,""))

                   IF IEN'>0

                       DO ERROR(.RESULT,"Could not find Display Group: "_NAME)

                       SET FAIL=1

 +4                SET INPUT("DG IEN",IEN)=""

 +5                SET INPUT("DG IEN",IEN,"START")=+$GET(INPUT("ROC DISPLAY GROUPS",NAME,"START"))

 +6                SET INPUT("DG IEN",IEN,"STOP")=+$GET(INPUT("ROC DISPLAY GROUPS",NAME,"STOP"))

               End DoDot:1

 +7        QUIT

 +8       ;

GETOIS(INPUT) ; find orderable items for each order

 +1        NEW CNT,NUM,ARRAY,OI,ORDIEN,POS,PXRMOIS

 +2        SET ORDIEN=0

FOR

               SET ORDIEN=$ORDER(INPUT("ROC ORDERS",ORDIEN))

               if ORDIEN'>0

                   QUIT

               Begin DoDot:1

 +3                KILL PXRMOIS

                   DO OIS^ORX8(.PXRMOIS,ORDIEN)

                   IF '$DATA(PXRMOIS)

                       QUIT

 +4                MERGE INPUT("ROC ORDERS",ORDIEN,"OI")=PXRMOIS

               End DoDot:1

 +5        QUIT

 +6       ;

GTORDERS(INPUT) ;

 +1        NEW DIEN,DATE,END,NODE,PAT,ORDIEN,ORN,PXRMOIS,START,STOP,ORLIST,MOD,PXRMINST,ORUPCHUK

 +2        SET PAT=$GET(INPUT("DFN"))

 +3        SET DIEN=0

FOR

               SET DIEN=$ORDER(INPUT("DG IEN",DIEN))

               if DIEN'>0

                   QUIT

               Begin DoDot:1

 +4                KILL ^TMP("ORR",$JOB)

 +5                SET START=$SELECT(INPUT("DG IEN",DIEN,"START")>0:INPUT("DG IEN",DIEN,"START"),1:$GET(INPUT("ROC START")))

 +6                SET STOP=$SELECT(INPUT("DG IEN",DIEN,"STOP")>0:INPUT("DG IEN",DIEN,"STOP"),1:$GET(INPUT("ROC STOP")))

 +7       ;call for current activities

 +8                DO EN^ORQ1(PAT_";DPT(",DIEN,1,,START,STOP,1)

 +9                SET DATE=""

FOR

                       SET DATE=$ORDER(^TMP("ORR",$JOB,DATE))

                       if DATE=""

                           QUIT

                       Begin DoDot:2

 +10                       FOR ORN=1:1:$GET(^TMP("ORR",$JOB,DATE,"TOT"))

                               Begin DoDot:3

 +11                               SET NODE=$GET(^TMP("ORR",$JOB,DATE,ORN))

 +12                               IF $DATA(INPUT("ROC ORDERS",+$PIECE(NODE,U)))

                                       QUIT

 +13                               IF ('$DATA(INPUT("ROC STATUS","*"))&('$DATA(INPUT("ROC STATUS",$PIECE(NODE,U,6)))))

                                       QUIT

 +14                               IF $DATA(INPUT("ROC ORDERED WITHIN"))&(($PIECE(NODE,U,3)<START)!($PIECE(NODE,U,3)>STOP))

                                       QUIT

 +15                               SET ORDIEN=+$PIECE(NODE,U)

 +16                               DO EN^ORX8(ORDIEN)

 +17                               SET NODE=NODE_U_$PIECE(ORUPCHUK("ORNP"),U)

 +18                               KILL ORUPCHUK

 +19                               SET INPUT("ROC ORDERS",ORDIEN)=NODE

 +20                               MERGE INPUT("ROC ORDERS",ORDIEN,"TX")=^TMP("ORR",$JOB,DATE,ORN,"TX")

 +21                               SET INPUT("ROC ORDERS",ORDIEN,"PKG ID")=$$PKGID^ORX8(ORDIEN)

 +22                               FOR PXRMINST=1:1

                                       SET MOD=$$VALUE^ORX8(ORDIEN,"MODIFIER",PXRMINST,"E")

                                       if MOD=""

                                           QUIT

                                       Begin DoDot:4

 +23                                       SET INPUT("ROC ORDERS",ORDIEN,"MODIFIERS",PXRMINST)=MOD

                                       End DoDot:4

 +24                               KILL PXRMOIS

                                   DO OIS^ORX8(.PXRMOIS,ORDIEN)

 +25                               IF $DATA(PXRMOIS)

                                       MERGE INPUT("ROC ORDERS",ORDIEN,"OI")=PXRMOIS

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +26       KILL ^TMP("ORR",$JOB)

 +27       QUIT

 +28      ;

GETVAL(INPUT,TYPE) ;

 +1        QUIT $GET(INPUT("VARIABLES",TYPE))

 +2       ;

REM(RESULT,INPUT) ; controller for reminder evaluation types

 +1        IF $DATA(INPUT("LR"))

               DO REMLIST(.RESULT,.INPUT)

               QUIT

 +2        IF $DATA(INPUT("REMINDERS"))

               DO REMEVAL(.RESULT,.INPUT)

               QUIT

 +3        DO REMOC(.RESULT,.INPUT)

 +4        QUIT

 +5       ;

REMMDEF(INPUT,DEFARR) ; update DEFARR with modifiers

 +1        NEW ITEM,NUM,SUB,PIECE,TEMP,VALUE

 +2        SET NUM=0

FOR

               SET NUM=$ORDER(DEFARR(20,NUM))

               if NUM'>0

                   QUIT

               Begin DoDot:1

 +3                SET ITEM=$PIECE($GET(DEFARR(20,NUM,0)),U)

                   IF ITEM=""

                       QUIT

 +4                IF '$DATA(INPUT("EVAL","FINDINGS",ITEM))

                       QUIT

 +5                SET SUB=""

FOR

                       SET SUB=$ORDER(INPUT("EVAL","FINDINGS",ITEM,SUB))

                       if SUB=""

                           QUIT

                       Begin DoDot:2

 +6                        SET PIECE=0

FOR

                               SET PIECE=$ORDER(INPUT("EVAL","FINDINGS",ITEM,SUB,PIECE))

                               if PIECE'>0

                                   QUIT

                               Begin DoDot:3

 +7                                SET VALUE=$GET(INPUT("EVAL","FINDINGS",ITEM,SUB,PIECE))

                                   IF VALUE=""

                                       QUIT

 +8                                IF VALUE["$$"

                                       SET TEMP="S VALUE="_VALUE

                                       XECUTE TEMP

 +9                                SET $PIECE(DEFARR(20,NUM,SUB),U,PIECE)=VALUE

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +10       IF $GET(INPUT("EVAL","EVAL DATE"))["$$"

               Begin DoDot:1

 +11               SET TEMP="S VALUE="_INPUT("EVAL","EVAL DATE")

                   XECUTE TEMP

 +12               SET INPUT("EVAL","NEW EVAL DATE")=VALUE

               End DoDot:1

               QUIT

 +13       QUIT

 +14      ;

REMEVAL(RESULT,INPUT) ;

 +1        NEW RIEN,FIEVAL,TODAY,OUTTYPE,PNAME,ONAME,PXRMSRCFF

 +2        SET PXRMSRCFF=1

 +3        KILL ^TMP("PXRHM",$JOB)

 +4        SET RIEN=0

FOR

               SET RIEN=$ORDER(INPUT("REMINDERS",RIEN))

               if '+RIEN

                   QUIT

               Begin DoDot:1

 +5                SET ONAME=$PIECE(INPUT("REMINDERS",RIEN),U)

                   SET FIEVAL=$PIECE(INPUT("REMINDERS",RIEN),U,2)

 +6                SET OUTTYPE=+$PIECE(INPUT("REMINDERS",RIEN),U,3)

                   SET TODAY=+$PIECE(INPUT("REMINDERS",RIEN),U,4)

 +7                DO MAINDF(INPUT("DFN"),RIEN,OUTTYPE,TODAY,FIEVAL)

 +8                SET PNAME=$PIECE($GET(^PXD(811.9,RIEN,0)),U,3)

 +9                IF PNAME=""

                       SET PNAME=$PIECE($GET(^PXD(811.9,RIEN,0)),U)

 +10               SET @RESULT@(ONAME)=$GET(^TMP("PXRHM",$JOB,RIEN,PNAME))

 +11               SET @RESULT@(ONAME,"PRINT NAME")=PNAME

 +12               IF FIEVAL

                       MERGE @RESULT@(ONAME,"FIEVAL")=^TMP("PXRHM",$JOB,RIEN,"FIEVAL")

 +13               IF OUTTYPE>0

                       MERGE @RESULT@(ONAME,"MAINTENANCE")=^TMP("PXRHM",$JOB,RIEN,PNAME,"TXT")

 +14               KILL ^TMP("PXRHM",$JOB)

 +15               IF $DATA(^TMP("PXRM BL DATA",$JOB))

                       Begin DoDot:2

 +16                       SET RIEN("C")=$GET(^TMP("PXRM BL DATA",$JOB,"REMINDER IEN"))

 +17                       SET PNAME=$GET(^TMP("PXRM BL DATA",$JOB,"REMINDER NAME"))

 +18                       IF RIEN("C")=""!(PNAME="")

                               QUIT

 +19                       SET @RESULT@(ONAME,"FINDINGS",PNAME)=$GET(^TMP("PXRM BL DATA",$JOB,"PXRHM",RIEN("C"),PNAME))

 +20                       IF FIEVAL

                               MERGE @RESULT@(ONAME,"FINDINGS",PNAME,"FIEVAL")=^TMP("PXRM BL DATA",$JOB,"FIEVAL")

 +21                       IF OUTTYPE>0

                               MERGE @RESULT@(ONAME,"FINDINGS",PNAME,"MAINTENANCE")=^TMP("PXRM BL DATA",$JOB,"PXRHM",RIEN("C"),PNAME,"TXT")

 +22                       KILL ^TMP("PXRM BL DATA",$JOB)

                       End DoDot:2

               End DoDot:1

 +23       QUIT

 +24      ;

MAINDF(DFN,PXRMITEM,OUTTYPE,EVALDT,SAVEFIE) ;

 +1        NEW DEFARR,FIEVAL,REMCFIEN,MESSAGE,FINDING

 +2        DO DEF^PXRMLDR(PXRMITEM,.DEFARR)

 +3        IF OUTTYPE>0

               Begin DoDot:1

 +4                SET REMCFIEN=+$ORDER(^PXRMD(811.4,"B","VA-REMINDER DEFINITION",""))

                   if REMCFIEN<1

                       QUIT

 +5                SET FINDING=0

FOR

                       SET FINDING=+$ORDER(DEFARR("E","PXRMD(811.4,",REMCFIEN,FINDING))

                       if '+FINDING

                           QUIT

                       SET $PIECE(DEFARR(20,FINDING,15),U,4)=OUTTYPE

               End DoDot:1

 +6       ;MAINDF^PXRM, which allows passing evaluation date, always saved the FIEVAL array

           IF $GET(EVALDT)?7N

               SET SAVEFIE=1

 +7       IF '$TEST

               SET EVALDT=$$NOW^XLFDT

 +8        DO EVAL^PXRM(DFN,.DEFARR,OUTTYPE,0,.FIEVAL,EVALDT)

 +9        IF $GET(SAVEFIE)

               MERGE ^TMP("PXRHM",$JOB,PXRMITEM,"FIEVAL")=FIEVAL

 +10       QUIT

 +11      ;

REMLIST(RESULT,INPUT) ;

 +1        NEW BEG,END,CNT,DATA,DATANAM,DATAVAL,FAIL,INC,LIEN,LNAME,NODE,NUM,OVER,PAT,PFNAME,PNAME,PLIST,PATCREAT,RETDATA,SECURE

 +2        SET LNAME=""

           SET FAIL=0

FOR

               SET LNAME=$ORDER(INPUT("LR",LNAME))

               if LNAME=""!(FAIL=1)

                   QUIT

               Begin DoDot:1

 +3                KILL BEG,END,LIEN,PFNAME,PNAME,PLIST,SECURE,OVER,RETDATA

 +4                SET LIEN=+$ORDER(^PXRM(810.4,"B",LNAME,""))

                   IF LIEN'>0

                       DO ERROR(.RESULT,"List Rule: "_LNAME_" not found")

                       SET FAIL=1

                       QUIT

 +5                SET NODE=$GET(INPUT("LR",LNAME))

                   SET PNAME=$PIECE(NODE,U)

                   SET BEG=$PIECE(NODE,U,2)

                   SET END=$PIECE(NODE,U,3)

                   SET SECURE=$PIECE(NODE,U,4)

                   SET OVER=$PIECE(NODE,U,5)

                   SET RETDATA=+$PIECE(NODE,U,6)

 +6                SET PLIST=$$REMPLCRE(PNAME,SECURE,OVER)

                   IF +PLIST'>0

                       DO ERROR(.RESULT,"Error could not find or create patient list "_PLNAME)

                       SET FAIL=1

                       QUIT

 +7                SET PFNAME=$PIECE(PLIST,U,2)

 +8                DO RUN^PXRMLCR(LIEN,+PLIST,"PXRMRULE",BEG,END,0,1)

 +9                IF '$DATA(^PXRMXP(810.5,+PLIST,30))

                       QUIT

 +10               SET NUM=0

FOR

                       SET NUM=$ORDER(^PXRMXP(810.5,+PLIST,30,NUM))

                       if NUM'>0

                           QUIT

                       Begin DoDot:2

 +11                       SET PAT=$PIECE($GET(^PXRMXP(810.5,+PLIST,30,NUM,0)),U)

                           IF PAT=""

                               QUIT

 +12                       SET @RESULT@(LNAME,PAT)=""

 +13                       IF RETDATA=0

                               QUIT

 +14                       SET CNT=0

FOR

                               SET CNT=$ORDER(^PXRMXP(810.5,+PLIST,30,NUM,"DATA",CNT))

                               if CNT'>0

                                   QUIT

                               Begin DoDot:3

 +15                               SET DATA=$GET(^PXRMXP(810.5,+PLIST,30,NUM,"DATA",CNT,0))

                                   IF DATA=""

                                       QUIT

 +16                               SET DATANAM=$PIECE($PIECE(DATA,U),",",2)

                                   SET DATAVAL=$PIECE(DATA,U,2)

                                   IF DATANAM=""

                                       QUIT

 +17                               SET @RESULT@(LNAME,PAT,"DATA",DATANAM)=DATAVAL

                               End DoDot:3

                       End DoDot:2

 +18               SET @RESULT@(LNAME,"PATIENT LIST CREATED")=PFNAME

 +19               SET @RESULT@(0)=1

               End DoDot:1

 +20       QUIT

 +21      ;

REMPLCRE(PLNAME,SECURE,OVER) ;

 +1        NEW FDA,IENS,NAME,NUM,RESULT,UNIQUE

 +2        SET (NUM,RESULT,UNIQUE)=0

 +3       ;if overwrite check to see if the list exist

 +4        IF OVER=1

               SET RESULT=$ORDER(^PXRMXP(810.5,"B",PLNAME,""))

 +5        IF RESULT>0

               QUIT RESULT

 +6        SET NAME=PLNAME

 +7       ;if not overwrite find unique and name exist create unique name

 +8        IF OVER=0

               IF $DATA(^PXRMXP(810.5,"B",NAME))>0

                   Begin DoDot:1

 +9                    FOR

                           if UNIQUE=1

                               QUIT

                           Begin DoDot:2

 +10                           SET NAME=PLNAME_" ("_$$NOW^XLFDT()_")"

 +11                           IF $DATA(^PXRMXP(810.5,"B",NAME))=0

                                   SET UNIQUE=1

                                   QUIT

 +12                           HANG 1

                           End DoDot:2

                   End DoDot:1

 +13      ;create stub in 810.5

 +14       SET IENS="?+1,"

 +15       SET FDA(810.5,IENS,.01)=NAME

           SET FDA(810.5,IENS,100)="L"

           SET FDA(810.5,IENS,.07)=DUZ

           SET FDA(810.5,IENS,.08)=$SELECT(SECURE=0:"PUB",1:"PVT")

 +16       DO UPDATE^DIE("","FDA","","MSG")

 +17      ;if error display message and quit

 +18       IF $DATA(MSG)

               QUIT 0

 +19       SET RESULT=$ORDER(^PXRMXP(810.5,"B",NAME,""))

 +20       QUIT RESULT_U_NAME

 +21      ;

REMOC(RESULT,INPUT) ; controller for reminder order checks

 +1        NEW DISPLAY,FOUND,GROUPS,NUM,OI,OINAME,ORDIEN,PAT,PNAME,SEV,STATUS,RNAME,RIEN,GNAME,OIGROUPS

 +2        IF '$DATA(INPUT("ROC","ALL"))

               MERGE GROUPS=INPUT("ROC")

 +3        IF '$DATA(INPUT("ROC ORDERS"))

               QUIT

 +4        SET PAT=$GET(INPUT("DFN"))

 +5        SET STATUS=0

 +6       ;loop through orders

 +7        SET ORDIEN=0

           SET FOUND=0

FOR

               SET ORDIEN=$ORDER(INPUT("ROC ORDERS",ORDIEN))

               if ORDIEN'>0

                   QUIT

               Begin DoDot:1

 +8       ;loop through orderable items for each order

 +9                SET OI=0

FOR

                       SET OI=$ORDER(INPUT("ROC ORDERS",ORDIEN,"OI",OI))

                       if OI'>0

                           QUIT

                       Begin DoDot:2

 +10                       SET OINAME=$PIECE($GET(INPUT("ROC ORDERS",ORDIEN,"OI",OI)),U)

 +11                       IF $DATA(INPUT("ROC RETURN TYPE","GROUPS"))

                               Begin DoDot:3

 +12                               DO GETGRPS^PXRMORCH(OI,.OIGROUPS)

                                   if '$DATA(OIGROUPS)

                                       QUIT

 +13                               SET @RESULT@(0)=1

 +14                               MERGE @RESULT@(ORDIEN,"GROUPS")=OIGROUPS

                               End DoDot:3

 +15      ;does not process reminder order checks

 +16                       IF '$DATA(INPUT("ROC RETURN TYPE","RULES"))

                               QUIT

 +17      ;Process OI against all Production Reminder Order checks Rule

 +18                       IF '$DATA(GROUPS)

                               DO ORDERCHK^PXRMORCH(PAT,OI,STATUS,0,0)

 +19      ;Process OI against Production Reminder Order Checks only found in the array of groups

 +20                       IF $DATA(GROUPS)

                               DO ORDERGRP^PXRMORCH(PAT,OI,STATUS,0,.GROUPS)

 +21      ;quit if no order checks found

 +22                       IF '$DATA(^TMP($JOB,OI))

                               QUIT

 +23                       SET @RESULT@(0)=1

 +24                       SET SEV=0

FOR

                               SET SEV=$ORDER(^TMP($JOB,OI,SEV))

                               if SEV'>0

                                   QUIT

                               Begin DoDot:3

 +25                               SET DISPLAY=""

FOR

                                       SET DISPLAY=$ORDER(^TMP($JOB,OI,SEV,DISPLAY))

                                       if DISPLAY=""

                                           QUIT

                                       Begin DoDot:4

 +26                                       SET RIEN=$ORDER(^PXD(801.1,"D",DISPLAY,0))

                                           IF RIEN>0

                                               SET RNAME=$PIECE($GET(^PXD(801.1,RIEN,0)),U)

 +27                                       IF RNAME=""

                                               SET RNAME=DISPLAY

 +28                                       SET @RESULT@(ORDIEN,"RULES",RNAME)=""

                                       End DoDot:4

                               End DoDot:3

 +29                       KILL ^TMP($JOB,OI)

                       End DoDot:2

 +30               IF '(($DATA(@RESULT@(ORDIEN,"RULES")))!($DATA(@RESULT@(ORDIEN,"GROUPS"))))

                       QUIT

 +31               SET @RESULT@(ORDIEN)=$GET(INPUT("ROC ORDERS",ORDIEN))

 +32               MERGE @RESULT@(ORDIEN,"TX")=INPUT("ROC ORDERS",ORDIEN,"TX")

 +33               IF $DATA(INPUT("ROC RETURN TYPE","OI"))

                       MERGE @RESULT@(ORDIEN,"OI")=INPUT("ROC ORDERS",ORDIEN,"OI")

               End DoDot:1

 +34       QUIT

 +35      ;

PXRMGEVA.m