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