PXRMLOGX ;SLC/PKR - Clinical Reminders logic cross-reference routines. ;03/29/2022
;;2.0;CLINICAL REMINDERS;**4,18,65**;Feb 04, 2005;Build 438
;
;==================
BLDAFL(IEN,KI,NODEP) ;Build a list of findings that can change the
;frequency age range set. This is called by FileMan whenever the
;minimum age, maximum age, or frequency fields of the findings
;multiple are edited.
;Do not execute as part of a verify fields.
I $G(DIUTIL)="VERIFY FIELDS" Q
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q
N FREQ,FLIST,FTYPE,IND,OK,NODE,NUM,STARTCHK
S STARTCHK=$S($D(^PXD(811.9,IEN,25)):100,1:150)
S FLIST="",OK=1,NUM=0
F NODE=20,25 D
. S FTYPE=$S(NODE=25:"FF",1:"")
. S IND=0
. F S IND=$O(^PXD(811.9,IEN,NODE,IND)) Q:+IND=0 D
..;If an entry is being deleted skip it.
.. I IND=$G(KI),NODE=NODEP Q
.. S FREQ=$P(^PXD(811.9,IEN,NODE,IND,0),U,4)
.. I FREQ'="" D
... S NUM=NUM+1
... I NUM>STARTCHK S OK=$$CHKSLEN(FLIST,";"_IND)
... I NUM>1 S FLIST=FLIST_";"
... I OK S FLIST=FLIST_FTYPE_IND
S OK=$$CHKSLEN(FLIST,NUM_U)
I OK S ^PXD(811.9,IEN,40)=NUM_U_FLIST
E D
. S ^PXD(811.9,IEN,40)=-1
. D ERRMSG("age")
Q
;
;==================
BLDALL(IEN,KI,NODEP) ;Build all the findings lists.
;Do not execute as part of a verify fields.
I $G(DIUTIL)="VERIFY FIELDS" Q
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q
I '$D(^PXD(811.9,IEN)) Q
D BLDPCLS^PXRMLOGX(IEN,KI,NODEP)
D BLDRESLS^PXRMLOGX(IEN,KI,NODEP)
D BLDAFL^PXRMLOGX(IEN,KI,NODEP)
D BLDINFL^PXRMLOGX(IEN,KI,NODEP)
Q
;
;==================
BLDCONTRALD(IEN,X1,X2) ;Build the CONTRAINDICATED LOGIC data.
;Do not execute as part of a verify fields.
I $G(DIUTIL)="VERIFY FIELDS" Q
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q
I X2="" S ^PXD(811.9,IEN,81)=0 Q
;Get the list of findings.
N FLIST,IND,NUM,OK,OPER,STACK,STARTCHK,T1,T2
S STARTCHK=$S($D(^PXD(811.9,IEN,25)):100,1:150)
S OPER="'U!&",OK=1,NUM=0,FLIST=""
D POSTFIX^PXRMSTAC(X2,OPER,.STACK)
F IND=1:1:STACK(0) D
. S T1=STACK(IND)
. I OPER[T1 Q
. I (T1="FF")!(T1="FI") D
.. S IND=IND+1
.. S T2=STACK(IND)
.. I NUM>0 S FLIST=FLIST_";"
.. S NUM=NUM+1
.. I NUM>STARTCHK S OK=$$CHKSLEN(FLIST,";"_IND)
.. I OK S FLIST=FLIST_$S(T1="FF":"FF"_T2,1:T2)
S OK=$$CHKSLEN(FLIST,NUM_U)
I OK S ^PXD(811.9,IEN,81)=NUM_U_FLIST
E D
. S ^PXD(811.9,IEN,81)=-1
. D ERRMSG("contraindicated")
Q
;
;==================
BLDINFL(IEN,KI,NODEP) ;Build the list of findings that are information only.
;This is called by the routines that build the resolution findings
;list, the patient cohort findings list, and the age finding list.
;Do not execute as part of a verify fields.
I $G(DIUTIL)="VERIFY FIELDS" Q
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q
N FIA,FLIST,FTYPE,IND,NODE,NUM,OK,SUB,STARTCHK,TEMP
S STARTCHK=$S($D(^PXD(811.9,IEN,25)):100,1:150)
F NODE=20,25 D
. S FTYPE=$S(NODE=25:"FF",1:"")
. S IND=0
. F S IND=$O(^PXD(811.9,IEN,NODE,IND)) Q:+IND=0 D
..;If an entry is being deleted skip it.
.. I IND=$G(KI),NODE=NODEP Q
.. S SUB=FTYPE_IND
.. S FIA(SUB)=""
;Remove the patient cohort logic findings.
S TEMP=$G(^PXD(811.9,IEN,32))
S NUM=+$P(TEMP,U,1)
S FLIST=$P(TEMP,U,2)
F IND=1:1:NUM D
. S TEMP=$P(FLIST,";",IND)
. I $D(FIA(TEMP)) K FIA(TEMP)
;Remove the resolution logic findings.
S TEMP=$G(^PXD(811.9,IEN,36))
S NUM=+$P(TEMP,U,1)
S FLIST=$P(TEMP,U,2)
F IND=1:1:NUM D
. S TEMP=$P(FLIST,";",IND)
. I $D(FIA(TEMP)) K FIA(TEMP)
;Remove the age findings.
S TEMP=$G(^PXD(811.9,IEN,40))
S NUM=+$P(TEMP,U,1)
S FLIST=$P(TEMP,U,2)
F IND=1:1:NUM D
. S TEMP=$P(FLIST,";",IND)
. I $D(FIA(TEMP)) K FIA(TEMP)
;Remove the contraindicated logic findings.
S TEMP=$G(^PXD(811.9,IEN,81))
S NUM=+$P(TEMP,U,1)
S FLIST=$P(TEMP,U,2)
F IND=1:1:NUM D
. S TEMP=$P(FLIST,";",IND)
. I $D(FIA(TEMP)) K FIA(TEMP)
;Remove the resolution logic findings.
S TEMP=$G(^PXD(811.9,IEN,91))
S NUM=+$P(TEMP,U,1)
S FLIST=$P(TEMP,U,2)
F IND=1:1:NUM D
. S TEMP=$P(FLIST,";",IND)
. I $D(FIA(TEMP)) K FIA(TEMP)
;
;What is left is the information findings.
S FLIST="",OK=1
S (IND,NUM)=0
F S IND=$O(FIA(IND)) Q:IND="" D
. S NUM=NUM+1
. I NUM>STARTCHK S OK=$$CHKSLEN(FLIST,";"_IND)
. I NUM>1 S FLIST=FLIST_";"
. I OK S FLIST=FLIST_IND
S OK=$$CHKSLEN(FLIST,NUM_U)
I OK S ^PXD(811.9,IEN,42)=NUM_U_FLIST
E D
. S ^PXD(811.9,IEN,42)=-1
. D ERRMSG("information")
Q
;
;==================
BLDPCLS(IEN,KI,NODEP) ;Build the Internal Patient Cohort Logic string for a
;reminder. This is called by FileMan whenever the USE IN PATIENT COHORT
;LOGIC field is edited or the user defined Patient Cohort Logic is
;killed. Also builds the patient cohort logic list.
;If there is a user defined PATIENT COHORT LOGIC then don't do anything.
;Do not execute as part of a verify fields.
I $G(DIUTIL)="VERIFY FIELDS" Q
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q
I $L($G(^PXD(811.9,IEN,30)))>0 Q
N FLIST,FTYPE,IND,NODE,NUM,OK,PCLOG,STARTCHK,TEMP,UPCLOG
S STARTCHK=$S($D(^PXD(811.9,IEN,25)):100,1:150)
S OK=1
S PCLOG="(SEX)&(AGE)"
S FLIST="SEX;AGE",NUM=2
F NODE=20,25 D
. S FTYPE=$S(NODE=20:"FI",NODE=25:"FF")
. S IND=0
. F S IND=$O(^PXD(811.9,IEN,NODE,IND)) Q:+IND=0 D
..;If an entry is being deleted skip it.
.. I IND=$G(KI),NODE=NODEP Q
.. S TEMP=^PXD(811.9,IEN,NODE,IND,0)
.. S UPCLOG=$P(TEMP,U,7)
.. I UPCLOG'="" D
... S PCLOG=PCLOG_UPCLOG_FTYPE_"("_IND_")"
... S NUM=NUM+1
... I NUM>STARTCHK S OK=$$CHKSLEN(FLIST,";"_IND)
... I OK S FLIST=FLIST_";"_$S(NODE=25:"FF"_IND,1:IND)
;Save the internal string and the findings list.
S OK=$$CHKSLEN(FLIST,NUM_U)
I OK D
. S ^PXD(811.9,IEN,31)=PCLOG
. S ^PXD(811.9,IEN,32)=NUM_U_FLIST
E D
. S ^PXD(811.9,IEN,32)=-1
. D ERRMSG("cohort")
Q
;
;==================
BLDREFLD(IEN,X1,X2) ;Build the REFUSED LOGIC data.
;Do not execute as part of a verify fields.
I $G(DIUTIL)="VERIFY FIELDS" Q
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q
I X2="" S ^PXD(811.9,IEN,91)=0 Q
;Get the list of findings.
N FLIST,IND,NUM,OK,OPER,STACK,STARTCHK,T1,T2
S STARTCHK=$S($D(^PXD(811.9,IEN,25)):100,1:150)
S OPER="'U!&",OK=1,NUM=0,FLIST=""
D POSTFIX^PXRMSTAC(X2,OPER,.STACK)
F IND=1:1:STACK(0) D
. S T1=STACK(IND)
. I OPER[T1 Q
. I (T1="FF")!(T1="FI") D
.. S IND=IND+1
.. S T2=STACK(IND)
.. I NUM>0 S FLIST=FLIST_";"
.. S NUM=NUM+1
.. I NUM>STARTCHK S OK=$$CHKSLEN(FLIST,";"_IND)
.. I OK S FLIST=FLIST_$S(T1="FF":"FF"_T2,1:T2)
S OK=$$CHKSLEN(FLIST,NUM_U)
I OK S ^PXD(811.9,IEN,91)=NUM_U_FLIST
E D
. S ^PXD(811.9,IEN,91)=-1
. D ERRMSG("contraindicated")
Q
;
;==================
BLDRESLS(IEN,KI,NODEP) ;Build the Internal Resolution Logic string for a
;reminder. This is called by FileMan whenever the USE IN RESOLUTION
;LOGIC field is edited or the user defined Resolution Logic is killed.
;If there is a user defined RESOLUTION LOGIC then don't do
;anything.
;Do not execute as part of a verify fields.
I $G(DIUTIL)="VERIFY FIELDS" Q
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q
I $L($G(^PXD(811.9,IEN,34)))>0 Q
N FLIST,FTYPE,IND,NODE,NUM,OK,RESLOG,STARTCHK,TEMP,URESLOG
S STARTCHK=$S($D(^PXD(811.9,IEN,25)):100,1:150)
S OK=1
S (FLIST,RESLOG)="",NUM=0
F NODE=20,25 D
. S FTYPE=$S(NODE=20:"FI",NODE=25:"FF")
. S IND=0
. F S IND=$O(^PXD(811.9,IEN,NODE,IND)) Q:+IND=0 D
..;If an entry is being deleted skip it.
.. I IND=$G(KI),NODE=NODEP Q
.. S TEMP=^PXD(811.9,IEN,NODE,IND,0)
.. S URESLOG=$P(TEMP,U,6)
.. I URESLOG'="" D
... S RESLOG=RESLOG_URESLOG_FTYPE_"("_IND_")"
... S NUM=NUM+1
... I NUM>STARTCHK S OK=$$CHKSLEN(FLIST,";"_IND)
... I NUM>1 S FLIST=FLIST_";"
... I OK S FLIST=FLIST_$S(NODE=25:"FF"_IND,1:IND)
;Save as the internal string and the findings list.
I RESLOG="" S ^PXD(811.9,IEN,35)=""
E D
. S TEMP=$E(RESLOG,1,1)
. S RESLOG=$S(TEMP="&":"(1)",TEMP="!":"(0)",1:"")_RESLOG
. S ^PXD(811.9,IEN,35)=RESLOG
S OK=$$CHKSLEN(FLIST,NUM_U)
I OK S ^PXD(811.9,IEN,36)=NUM_U_FLIST
I 'OK D
. S ^PXD(811.9,IEN,36)=-1
. D ERRMSG("resolution")
;Check the resolution logic to see if it can be satisfied solely
;by function findings.
I NUM>0,FLIST["FF",RESLOG'="" D CRESLOG^PXRMFFDB(NUM,FLIST,RESLOG)
Q
;
;==================
CHKSLEN(STRING,WORD) ;Determine if appending WORD to STRING will cause
;string to exceed the maximum string length.
N MAXSLEN S MAXSLEN=512
I ($L(STRING)+$L(WORD))>MAXSLEN Q 0
Q 1
;
;==================
CPPCLS(IEN,X) ;Copy the user input Patient Cohort Logic string to the
;Internal Patient Cohort Logic string.
;Do not execute as part of a verify fields.
I $G(DIUTIL)="VERIFY FIELDS" Q
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q
S ^PXD(811.9,IEN,31)=X
;Get the list of findings.
N FLIST,IND,NUM,OK,OPER,STACK,STARTCHK,T1,T2
S STARTCHK=$S($D(^PXD(811.9,IEN,25)):100,1:150)
S OPER="'U!&",OK=1,NUM=0,FLIST=""
D POSTFIX^PXRMSTAC(X,OPER,.STACK)
F IND=1:1:STACK(0) D
. S T1=STACK(IND)
. I OPER[T1 Q
. I (T1="AGE")!(T1="SEX") D Q
.. I NUM>0 S FLIST=FLIST_";"
.. S NUM=NUM+1,FLIST=FLIST_T1
. I (T1="FF")!(T1="FI") D
.. S IND=IND+1
.. S T2=STACK(IND)
.. I NUM>0 S FLIST=FLIST_";"
.. S NUM=NUM+1
.. I NUM>STARTCHK S OK=$$CHKSLEN(FLIST,";"_IND)
.. I OK S FLIST=FLIST_$S(T1="FF":"FF"_T2,1:T2)
S OK=$$CHKSLEN(FLIST,NUM_U)
I OK S ^PXD(811.9,IEN,32)=NUM_U_FLIST
E D
. S ^PXD(811.9,IEN,32)=-1
. D ERRMSG("cohort")
Q
;
;==================
CPRESLS(IEN,X) ;Copy the user input Resolution Logic string to the
;Internal Resolution Logic string.
;Do not execute as part of a verify fields.
I $G(DIUTIL)="VERIFY FIELDS" Q
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q
S ^PXD(811.9,IEN,35)=X
;Build the list of findings
;Get the list of findings.
N FLIST,IND,NUM,OK,OPER,STACK,STARTCHK,T1,T2
S STARTCHK=$S($D(^PXD(811.9,IEN,25)):100,1:150)
;The unary NOT operator is stored as 'U in the stack.
S OPER="'U!&",OK=1,NUM=0,FLIST=""
D POSTFIX^PXRMSTAC(X,OPER,.STACK)
F IND=1:1:STACK(0) D
. S T1=STACK(IND)
. I OPER[T1 Q
. S IND=IND+1
. S T2=STACK(IND)
. S NUM=NUM+1
. I NUM>STARTCHK S OK=$$CHKSLEN(FLIST,";"_IND)
. I NUM>1 S FLIST=FLIST_";"
. I OK S FLIST=FLIST_$S(T1="FF":"FF"_T2,1:T2)
S OK=$$CHKSLEN(FLIST,NUM_U)
I OK D
. S ^PXD(811.9,IEN,36)=NUM_U_FLIST
.;Check the resolution logic to see if it can be satisfied solely
.;by function findings.
. I NUM>0,FLIST["FF",X'="" D CRESLOG^PXRMFFDB(NUM,FLIST,X)
I 'OK D
. S ^PXD(811.9,IEN,40)=-1
. D ERRMSG("resolution")
Q
;
;==================
DELNXR(X2) ;For a new style cross-reference check X2 to determine
;if a delete is being done. If it is a delete all the X2 elements will
;be null.
N IND,X2NULL
S X2NULL=1
S IND=0
F S IND=$O(X2(IND)) Q:(+IND=0)!('X2NULL) D
. I X2(IND)'="" S X2NULL=0
Q X2NULL
;
;==================
EDITNXR(X1,X2) ;For a new style cross-reference check X1 and X2 to determine
;if an edit is being done.
N ADD,AREDIFF,EDIT,IND,X1NULL,X2NULL
S AREDIFF=0
S (X1NULL,X2NULL)=1
S IND=0
F S IND=$O(X1(IND)) Q:+IND=0 D
. I X1(IND)'="" S X1NULL=0
. I X2(IND)'="" S X2NULL=0
. I X1(IND)'=X2(IND) S AREDIFF=1
I X1NULL&'X2NULL S ADD=1
E S ADD=0
I 'X1NULL&'X2NULL&AREDIFF S EDIT=1
E S EDIT=0
Q (ADD!EDIT)
;
;==================
ERRMSG(FTYPE) ;Display too many findings error message.
N TEXT
S TEXT(1)=" "
S TEXT(2)="Error - The number of "_FTYPE_" findings exceeds the maximum allowed!"
S TEXT(3)="The reminder will not function properly until some are removed."
S TEXT(4)=" "
D EN^DDIOL(.TEXT)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMLOGX 11798 printed Apr 09, 2024@20:55:06 Page 2
PXRMLOGX ;SLC/PKR - Clinical Reminders logic cross-reference routines. ;03/29/2022
+1 ;;2.0;CLINICAL REMINDERS;**4,18,65**;Feb 04, 2005;Build 438
+2 ;
+3 ;==================
BLDAFL(IEN,KI,NODEP) ;Build a list of findings that can change the
+1 ;frequency age range set. This is called by FileMan whenever the
+2 ;minimum age, maximum age, or frequency fields of the findings
+3 ;multiple are edited.
+4 ;Do not execute as part of a verify fields.
+5 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT
+6 ;Do not execute as part of exchange.
+7 IF $GET(PXRMEXCH)
QUIT
+8 NEW FREQ,FLIST,FTYPE,IND,OK,NODE,NUM,STARTCHK
+9 SET STARTCHK=$SELECT($DATA(^PXD(811.9,IEN,25)):100,1:150)
+10 SET FLIST=""
SET OK=1
SET NUM=0
+11 FOR NODE=20,25
Begin DoDot:1
+12 SET FTYPE=$SELECT(NODE=25:"FF",1:"")
+13 SET IND=0
+14 FOR
SET IND=$ORDER(^PXD(811.9,IEN,NODE,IND))
if +IND=0
QUIT
Begin DoDot:2
+15 ;If an entry is being deleted skip it.
+16 IF IND=$GET(KI)
IF NODE=NODEP
QUIT
+17 SET FREQ=$PIECE(^PXD(811.9,IEN,NODE,IND,0),U,4)
+18 IF FREQ'=""
Begin DoDot:3
+19 SET NUM=NUM+1
+20 IF NUM>STARTCHK
SET OK=$$CHKSLEN(FLIST,";"_IND)
+21 IF NUM>1
SET FLIST=FLIST_";"
+22 IF OK
SET FLIST=FLIST_FTYPE_IND
End DoDot:3
End DoDot:2
End DoDot:1
+23 SET OK=$$CHKSLEN(FLIST,NUM_U)
+24 IF OK
SET ^PXD(811.9,IEN,40)=NUM_U_FLIST
+25 IF '$TEST
Begin DoDot:1
+26 SET ^PXD(811.9,IEN,40)=-1
+27 DO ERRMSG("age")
End DoDot:1
+28 QUIT
+29 ;
+30 ;==================
BLDALL(IEN,KI,NODEP) ;Build all the findings lists.
+1 ;Do not execute as part of a verify fields.
+2 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT
+3 ;Do not execute as part of exchange.
+4 IF $GET(PXRMEXCH)
QUIT
+5 IF '$DATA(^PXD(811.9,IEN))
QUIT
+6 DO BLDPCLS^PXRMLOGX(IEN,KI,NODEP)
+7 DO BLDRESLS^PXRMLOGX(IEN,KI,NODEP)
+8 DO BLDAFL^PXRMLOGX(IEN,KI,NODEP)
+9 DO BLDINFL^PXRMLOGX(IEN,KI,NODEP)
+10 QUIT
+11 ;
+12 ;==================
BLDCONTRALD(IEN,X1,X2) ;Build the CONTRAINDICATED LOGIC data.
+1 ;Do not execute as part of a verify fields.
+2 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT
+3 ;Do not execute as part of exchange.
+4 IF $GET(PXRMEXCH)
QUIT
+5 IF X2=""
SET ^PXD(811.9,IEN,81)=0
QUIT
+6 ;Get the list of findings.
+7 NEW FLIST,IND,NUM,OK,OPER,STACK,STARTCHK,T1,T2
+8 SET STARTCHK=$SELECT($DATA(^PXD(811.9,IEN,25)):100,1:150)
+9 SET OPER="'U!&"
SET OK=1
SET NUM=0
SET FLIST=""
+10 DO POSTFIX^PXRMSTAC(X2,OPER,.STACK)
+11 FOR IND=1:1:STACK(0)
Begin DoDot:1
+12 SET T1=STACK(IND)
+13 IF OPER[T1
QUIT
+14 IF (T1="FF")!(T1="FI")
Begin DoDot:2
+15 SET IND=IND+1
+16 SET T2=STACK(IND)
+17 IF NUM>0
SET FLIST=FLIST_";"
+18 SET NUM=NUM+1
+19 IF NUM>STARTCHK
SET OK=$$CHKSLEN(FLIST,";"_IND)
+20 IF OK
SET FLIST=FLIST_$SELECT(T1="FF":"FF"_T2,1:T2)
End DoDot:2
End DoDot:1
+21 SET OK=$$CHKSLEN(FLIST,NUM_U)
+22 IF OK
SET ^PXD(811.9,IEN,81)=NUM_U_FLIST
+23 IF '$TEST
Begin DoDot:1
+24 SET ^PXD(811.9,IEN,81)=-1
+25 DO ERRMSG("contraindicated")
End DoDot:1
+26 QUIT
+27 ;
+28 ;==================
BLDINFL(IEN,KI,NODEP) ;Build the list of findings that are information only.
+1 ;This is called by the routines that build the resolution findings
+2 ;list, the patient cohort findings list, and the age finding list.
+3 ;Do not execute as part of a verify fields.
+4 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT
+5 ;Do not execute as part of exchange.
+6 IF $GET(PXRMEXCH)
QUIT
+7 NEW FIA,FLIST,FTYPE,IND,NODE,NUM,OK,SUB,STARTCHK,TEMP
+8 SET STARTCHK=$SELECT($DATA(^PXD(811.9,IEN,25)):100,1:150)
+9 FOR NODE=20,25
Begin DoDot:1
+10 SET FTYPE=$SELECT(NODE=25:"FF",1:"")
+11 SET IND=0
+12 FOR
SET IND=$ORDER(^PXD(811.9,IEN,NODE,IND))
if +IND=0
QUIT
Begin DoDot:2
+13 ;If an entry is being deleted skip it.
+14 IF IND=$GET(KI)
IF NODE=NODEP
QUIT
+15 SET SUB=FTYPE_IND
+16 SET FIA(SUB)=""
End DoDot:2
End DoDot:1
+17 ;Remove the patient cohort logic findings.
+18 SET TEMP=$GET(^PXD(811.9,IEN,32))
+19 SET NUM=+$PIECE(TEMP,U,1)
+20 SET FLIST=$PIECE(TEMP,U,2)
+21 FOR IND=1:1:NUM
Begin DoDot:1
+22 SET TEMP=$PIECE(FLIST,";",IND)
+23 IF $DATA(FIA(TEMP))
KILL FIA(TEMP)
End DoDot:1
+24 ;Remove the resolution logic findings.
+25 SET TEMP=$GET(^PXD(811.9,IEN,36))
+26 SET NUM=+$PIECE(TEMP,U,1)
+27 SET FLIST=$PIECE(TEMP,U,2)
+28 FOR IND=1:1:NUM
Begin DoDot:1
+29 SET TEMP=$PIECE(FLIST,";",IND)
+30 IF $DATA(FIA(TEMP))
KILL FIA(TEMP)
End DoDot:1
+31 ;Remove the age findings.
+32 SET TEMP=$GET(^PXD(811.9,IEN,40))
+33 SET NUM=+$PIECE(TEMP,U,1)
+34 SET FLIST=$PIECE(TEMP,U,2)
+35 FOR IND=1:1:NUM
Begin DoDot:1
+36 SET TEMP=$PIECE(FLIST,";",IND)
+37 IF $DATA(FIA(TEMP))
KILL FIA(TEMP)
End DoDot:1
+38 ;Remove the contraindicated logic findings.
+39 SET TEMP=$GET(^PXD(811.9,IEN,81))
+40 SET NUM=+$PIECE(TEMP,U,1)
+41 SET FLIST=$PIECE(TEMP,U,2)
+42 FOR IND=1:1:NUM
Begin DoDot:1
+43 SET TEMP=$PIECE(FLIST,";",IND)
+44 IF $DATA(FIA(TEMP))
KILL FIA(TEMP)
End DoDot:1
+45 ;Remove the resolution logic findings.
+46 SET TEMP=$GET(^PXD(811.9,IEN,91))
+47 SET NUM=+$PIECE(TEMP,U,1)
+48 SET FLIST=$PIECE(TEMP,U,2)
+49 FOR IND=1:1:NUM
Begin DoDot:1
+50 SET TEMP=$PIECE(FLIST,";",IND)
+51 IF $DATA(FIA(TEMP))
KILL FIA(TEMP)
End DoDot:1
+52 ;
+53 ;What is left is the information findings.
+54 SET FLIST=""
SET OK=1
+55 SET (IND,NUM)=0
+56 FOR
SET IND=$ORDER(FIA(IND))
if IND=""
QUIT
Begin DoDot:1
+57 SET NUM=NUM+1
+58 IF NUM>STARTCHK
SET OK=$$CHKSLEN(FLIST,";"_IND)
+59 IF NUM>1
SET FLIST=FLIST_";"
+60 IF OK
SET FLIST=FLIST_IND
End DoDot:1
+61 SET OK=$$CHKSLEN(FLIST,NUM_U)
+62 IF OK
SET ^PXD(811.9,IEN,42)=NUM_U_FLIST
+63 IF '$TEST
Begin DoDot:1
+64 SET ^PXD(811.9,IEN,42)=-1
+65 DO ERRMSG("information")
End DoDot:1
+66 QUIT
+67 ;
+68 ;==================
BLDPCLS(IEN,KI,NODEP) ;Build the Internal Patient Cohort Logic string for a
+1 ;reminder. This is called by FileMan whenever the USE IN PATIENT COHORT
+2 ;LOGIC field is edited or the user defined Patient Cohort Logic is
+3 ;killed. Also builds the patient cohort logic list.
+4 ;If there is a user defined PATIENT COHORT LOGIC then don't do anything.
+5 ;Do not execute as part of a verify fields.
+6 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT
+7 ;Do not execute as part of exchange.
+8 IF $GET(PXRMEXCH)
QUIT
+9 IF $LENGTH($GET(^PXD(811.9,IEN,30)))>0
QUIT
+10 NEW FLIST,FTYPE,IND,NODE,NUM,OK,PCLOG,STARTCHK,TEMP,UPCLOG
+11 SET STARTCHK=$SELECT($DATA(^PXD(811.9,IEN,25)):100,1:150)
+12 SET OK=1
+13 SET PCLOG="(SEX)&(AGE)"
+14 SET FLIST="SEX;AGE"
SET NUM=2
+15 FOR NODE=20,25
Begin DoDot:1
+16 SET FTYPE=$SELECT(NODE=20:"FI",NODE=25:"FF")
+17 SET IND=0
+18 FOR
SET IND=$ORDER(^PXD(811.9,IEN,NODE,IND))
if +IND=0
QUIT
Begin DoDot:2
+19 ;If an entry is being deleted skip it.
+20 IF IND=$GET(KI)
IF NODE=NODEP
QUIT
+21 SET TEMP=^PXD(811.9,IEN,NODE,IND,0)
+22 SET UPCLOG=$PIECE(TEMP,U,7)
+23 IF UPCLOG'=""
Begin DoDot:3
+24 SET PCLOG=PCLOG_UPCLOG_FTYPE_"("_IND_")"
+25 SET NUM=NUM+1
+26 IF NUM>STARTCHK
SET OK=$$CHKSLEN(FLIST,";"_IND)
+27 IF OK
SET FLIST=FLIST_";"_$SELECT(NODE=25:"FF"_IND,1:IND)
End DoDot:3
End DoDot:2
End DoDot:1
+28 ;Save the internal string and the findings list.
+29 SET OK=$$CHKSLEN(FLIST,NUM_U)
+30 IF OK
Begin DoDot:1
+31 SET ^PXD(811.9,IEN,31)=PCLOG
+32 SET ^PXD(811.9,IEN,32)=NUM_U_FLIST
End DoDot:1
+33 IF '$TEST
Begin DoDot:1
+34 SET ^PXD(811.9,IEN,32)=-1
+35 DO ERRMSG("cohort")
End DoDot:1
+36 QUIT
+37 ;
+38 ;==================
BLDREFLD(IEN,X1,X2) ;Build the REFUSED LOGIC data.
+1 ;Do not execute as part of a verify fields.
+2 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT
+3 ;Do not execute as part of exchange.
+4 IF $GET(PXRMEXCH)
QUIT
+5 IF X2=""
SET ^PXD(811.9,IEN,91)=0
QUIT
+6 ;Get the list of findings.
+7 NEW FLIST,IND,NUM,OK,OPER,STACK,STARTCHK,T1,T2
+8 SET STARTCHK=$SELECT($DATA(^PXD(811.9,IEN,25)):100,1:150)
+9 SET OPER="'U!&"
SET OK=1
SET NUM=0
SET FLIST=""
+10 DO POSTFIX^PXRMSTAC(X2,OPER,.STACK)
+11 FOR IND=1:1:STACK(0)
Begin DoDot:1
+12 SET T1=STACK(IND)
+13 IF OPER[T1
QUIT
+14 IF (T1="FF")!(T1="FI")
Begin DoDot:2
+15 SET IND=IND+1
+16 SET T2=STACK(IND)
+17 IF NUM>0
SET FLIST=FLIST_";"
+18 SET NUM=NUM+1
+19 IF NUM>STARTCHK
SET OK=$$CHKSLEN(FLIST,";"_IND)
+20 IF OK
SET FLIST=FLIST_$SELECT(T1="FF":"FF"_T2,1:T2)
End DoDot:2
End DoDot:1
+21 SET OK=$$CHKSLEN(FLIST,NUM_U)
+22 IF OK
SET ^PXD(811.9,IEN,91)=NUM_U_FLIST
+23 IF '$TEST
Begin DoDot:1
+24 SET ^PXD(811.9,IEN,91)=-1
+25 DO ERRMSG("contraindicated")
End DoDot:1
+26 QUIT
+27 ;
+28 ;==================
BLDRESLS(IEN,KI,NODEP) ;Build the Internal Resolution Logic string for a
+1 ;reminder. This is called by FileMan whenever the USE IN RESOLUTION
+2 ;LOGIC field is edited or the user defined Resolution Logic is killed.
+3 ;If there is a user defined RESOLUTION LOGIC then don't do
+4 ;anything.
+5 ;Do not execute as part of a verify fields.
+6 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT
+7 ;Do not execute as part of exchange.
+8 IF $GET(PXRMEXCH)
QUIT
+9 IF $LENGTH($GET(^PXD(811.9,IEN,34)))>0
QUIT
+10 NEW FLIST,FTYPE,IND,NODE,NUM,OK,RESLOG,STARTCHK,TEMP,URESLOG
+11 SET STARTCHK=$SELECT($DATA(^PXD(811.9,IEN,25)):100,1:150)
+12 SET OK=1
+13 SET (FLIST,RESLOG)=""
SET NUM=0
+14 FOR NODE=20,25
Begin DoDot:1
+15 SET FTYPE=$SELECT(NODE=20:"FI",NODE=25:"FF")
+16 SET IND=0
+17 FOR
SET IND=$ORDER(^PXD(811.9,IEN,NODE,IND))
if +IND=0
QUIT
Begin DoDot:2
+18 ;If an entry is being deleted skip it.
+19 IF IND=$GET(KI)
IF NODE=NODEP
QUIT
+20 SET TEMP=^PXD(811.9,IEN,NODE,IND,0)
+21 SET URESLOG=$PIECE(TEMP,U,6)
+22 IF URESLOG'=""
Begin DoDot:3
+23 SET RESLOG=RESLOG_URESLOG_FTYPE_"("_IND_")"
+24 SET NUM=NUM+1
+25 IF NUM>STARTCHK
SET OK=$$CHKSLEN(FLIST,";"_IND)
+26 IF NUM>1
SET FLIST=FLIST_";"
+27 IF OK
SET FLIST=FLIST_$SELECT(NODE=25:"FF"_IND,1:IND)
End DoDot:3
End DoDot:2
End DoDot:1
+28 ;Save as the internal string and the findings list.
+29 IF RESLOG=""
SET ^PXD(811.9,IEN,35)=""
+30 IF '$TEST
Begin DoDot:1
+31 SET TEMP=$EXTRACT(RESLOG,1,1)
+32 SET RESLOG=$SELECT(TEMP="&":"(1)",TEMP="!":"(0)",1:"")_RESLOG
+33 SET ^PXD(811.9,IEN,35)=RESLOG
End DoDot:1
+34 SET OK=$$CHKSLEN(FLIST,NUM_U)
+35 IF OK
SET ^PXD(811.9,IEN,36)=NUM_U_FLIST
+36 IF 'OK
Begin DoDot:1
+37 SET ^PXD(811.9,IEN,36)=-1
+38 DO ERRMSG("resolution")
End DoDot:1
+39 ;Check the resolution logic to see if it can be satisfied solely
+40 ;by function findings.
+41 IF NUM>0
IF FLIST["FF"
IF RESLOG'=""
DO CRESLOG^PXRMFFDB(NUM,FLIST,RESLOG)
+42 QUIT
+43 ;
+44 ;==================
CHKSLEN(STRING,WORD) ;Determine if appending WORD to STRING will cause
+1 ;string to exceed the maximum string length.
+2 NEW MAXSLEN
SET MAXSLEN=512
+3 IF ($LENGTH(STRING)+$LENGTH(WORD))>MAXSLEN
QUIT 0
+4 QUIT 1
+5 ;
+6 ;==================
CPPCLS(IEN,X) ;Copy the user input Patient Cohort Logic string to the
+1 ;Internal Patient Cohort Logic string.
+2 ;Do not execute as part of a verify fields.
+3 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT
+4 ;Do not execute as part of exchange.
+5 IF $GET(PXRMEXCH)
QUIT
+6 SET ^PXD(811.9,IEN,31)=X
+7 ;Get the list of findings.
+8 NEW FLIST,IND,NUM,OK,OPER,STACK,STARTCHK,T1,T2
+9 SET STARTCHK=$SELECT($DATA(^PXD(811.9,IEN,25)):100,1:150)
+10 SET OPER="'U!&"
SET OK=1
SET NUM=0
SET FLIST=""
+11 DO POSTFIX^PXRMSTAC(X,OPER,.STACK)
+12 FOR IND=1:1:STACK(0)
Begin DoDot:1
+13 SET T1=STACK(IND)
+14 IF OPER[T1
QUIT
+15 IF (T1="AGE")!(T1="SEX")
Begin DoDot:2
+16 IF NUM>0
SET FLIST=FLIST_";"
+17 SET NUM=NUM+1
SET FLIST=FLIST_T1
End DoDot:2
QUIT
+18 IF (T1="FF")!(T1="FI")
Begin DoDot:2
+19 SET IND=IND+1
+20 SET T2=STACK(IND)
+21 IF NUM>0
SET FLIST=FLIST_";"
+22 SET NUM=NUM+1
+23 IF NUM>STARTCHK
SET OK=$$CHKSLEN(FLIST,";"_IND)
+24 IF OK
SET FLIST=FLIST_$SELECT(T1="FF":"FF"_T2,1:T2)
End DoDot:2
End DoDot:1
+25 SET OK=$$CHKSLEN(FLIST,NUM_U)
+26 IF OK
SET ^PXD(811.9,IEN,32)=NUM_U_FLIST
+27 IF '$TEST
Begin DoDot:1
+28 SET ^PXD(811.9,IEN,32)=-1
+29 DO ERRMSG("cohort")
End DoDot:1
+30 QUIT
+31 ;
+32 ;==================
CPRESLS(IEN,X) ;Copy the user input Resolution Logic string to the
+1 ;Internal Resolution Logic string.
+2 ;Do not execute as part of a verify fields.
+3 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT
+4 ;Do not execute as part of exchange.
+5 IF $GET(PXRMEXCH)
QUIT
+6 SET ^PXD(811.9,IEN,35)=X
+7 ;Build the list of findings
+8 ;Get the list of findings.
+9 NEW FLIST,IND,NUM,OK,OPER,STACK,STARTCHK,T1,T2
+10 SET STARTCHK=$SELECT($DATA(^PXD(811.9,IEN,25)):100,1:150)
+11 ;The unary NOT operator is stored as 'U in the stack.
+12 SET OPER="'U!&"
SET OK=1
SET NUM=0
SET FLIST=""
+13 DO POSTFIX^PXRMSTAC(X,OPER,.STACK)
+14 FOR IND=1:1:STACK(0)
Begin DoDot:1
+15 SET T1=STACK(IND)
+16 IF OPER[T1
QUIT
+17 SET IND=IND+1
+18 SET T2=STACK(IND)
+19 SET NUM=NUM+1
+20 IF NUM>STARTCHK
SET OK=$$CHKSLEN(FLIST,";"_IND)
+21 IF NUM>1
SET FLIST=FLIST_";"
+22 IF OK
SET FLIST=FLIST_$SELECT(T1="FF":"FF"_T2,1:T2)
End DoDot:1
+23 SET OK=$$CHKSLEN(FLIST,NUM_U)
+24 IF OK
Begin DoDot:1
+25 SET ^PXD(811.9,IEN,36)=NUM_U_FLIST
+26 ;Check the resolution logic to see if it can be satisfied solely
+27 ;by function findings.
+28 IF NUM>0
IF FLIST["FF"
IF X'=""
DO CRESLOG^PXRMFFDB(NUM,FLIST,X)
End DoDot:1
+29 IF 'OK
Begin DoDot:1
+30 SET ^PXD(811.9,IEN,40)=-1
+31 DO ERRMSG("resolution")
End DoDot:1
+32 QUIT
+33 ;
+34 ;==================
DELNXR(X2) ;For a new style cross-reference check X2 to determine
+1 ;if a delete is being done. If it is a delete all the X2 elements will
+2 ;be null.
+3 NEW IND,X2NULL
+4 SET X2NULL=1
+5 SET IND=0
+6 FOR
SET IND=$ORDER(X2(IND))
if (+IND=0)!('X2NULL)
QUIT
Begin DoDot:1
+7 IF X2(IND)'=""
SET X2NULL=0
End DoDot:1
+8 QUIT X2NULL
+9 ;
+10 ;==================
EDITNXR(X1,X2) ;For a new style cross-reference check X1 and X2 to determine
+1 ;if an edit is being done.
+2 NEW ADD,AREDIFF,EDIT,IND,X1NULL,X2NULL
+3 SET AREDIFF=0
+4 SET (X1NULL,X2NULL)=1
+5 SET IND=0
+6 FOR
SET IND=$ORDER(X1(IND))
if +IND=0
QUIT
Begin DoDot:1
+7 IF X1(IND)'=""
SET X1NULL=0
+8 IF X2(IND)'=""
SET X2NULL=0
+9 IF X1(IND)'=X2(IND)
SET AREDIFF=1
End DoDot:1
+10 IF X1NULL&'X2NULL
SET ADD=1
+11 IF '$TEST
SET ADD=0
+12 IF 'X1NULL&'X2NULL&AREDIFF
SET EDIT=1
+13 IF '$TEST
SET EDIT=0
+14 QUIT (ADD!EDIT)
+15 ;
+16 ;==================
ERRMSG(FTYPE) ;Display too many findings error message.
+1 NEW TEXT
+2 SET TEXT(1)=" "
+3 SET TEXT(2)="Error - The number of "_FTYPE_" findings exceeds the maximum allowed!"
+4 SET TEXT(3)="The reminder will not function properly until some are removed."
+5 SET TEXT(4)=" "
+6 DO EN^DDIOL(.TEXT)
+7 QUIT
+8 ;
