PXRMPTL ;SLC/DLT,PKR,PJH - Print Clinical Reminders logic ;02/04/2011
;;2.0;CLINICAL REMINDERS;**4,12,18**;Feb 04, 2005;Build 152
;
;====================================================
BLDFLST(RITEM,FL) ;Build the list of findings defined for this reminder.
N IC,TEMP,GLOB,SUB,NAME
;Build a list of findings.
S IC=0
F S IC=$O(^PXD(811.9,RITEM,20,IC)) Q:+IC=0 D
. S TEMP=$P(^PXD(811.9,RITEM,20,IC,0),U)
. S GLOB=$P(TEMP,";",2),SUB=$P(TEMP,";")
. S NAME=$S(GLOB="":"???",1:$P($G(@(U_GLOB_SUB_",0)")),U))
. S FL(IC)=NAME
Q
;
;====================================================
CDUE(CDUE,FL,NL,ARRAY) ;Expand the custom date due string into ARRAY.
N FILIST,FREQLIST,FUNCTION,IND,OPLIST,NARGS
D PARSE^PXRMCDUE(CDUE,.FUNCTION,.NARGS,.FILIST,.FREQLIST,.OPLIST)
S ARRAY(1)=FUNCTION_"(",NL=1
F IND=1:1:NARGS D
. S NL=NL+1
. S ARRAY(NL)=FL(FILIST(IND))_OPLIST(IND)_FREQLIST(IND)
. I IND<NARGS S ARRAY(NL)=ARRAY(NL)_", "
S NL=NL+1,ARRAY(NL)=")"
Q
;
;====================================================
COHORT(DA) ;
N ARRAY,CNT,LINE,NODE,NLINES,OUTPUT
F NODE=60,61,65,66,70,71,75,76 I $D(^PXD(811.9,DA,NODE))>0 D
. I NODE=60 W !,"General Patient Cohort Found Text:"
. I NODE=61 W !,"General Patient Cohort Not Found Text:"
. I NODE=65 W !,"General Resolution Found Text:"
. I NODE=66 W !,"General Resolution Not Found Text:"
. I NODE=70 W !,"Summary Patient Cohort Found Text:"
. I NODE=71 W !,"Summary Patient Cohort Not Found Text:"
. I NODE=75 W !,"Summary Resolution Found Text:"
. I NODE=76 W !,"Summary Resolution Not Found Text:"
. S (CNT,LINE)=0 F S LINE=$O(^PXD(811.9,DA,NODE,LINE)) Q:LINE="" D
.. S CNT=CNT+1 S ARRAY(CNT)=$G(^PXD(811.9,DA,NODE,LINE,0))
. I $D(ARRAY)>0 D FORMAT^PXRMTEXT(5,78,CNT,.ARRAY,.NLINES,.OUTPUT)
. I NLINES>0 F CNT=1:1:NLINES W !,OUTPUT(CNT)
. W !
Q
;
;====================================================
DISLOG ;Display the patient cohort, resolution logic, and custom date due.
;Determine if this is a default adhoc logic or user modified logic
N CDUE,CUSTOM,FL,IND,LARRAY,LOGSTR,MAXLEN,NLOGLIN,NPL
N PARRAY,RITEM,SEP
S MAXLEN=72
;Build the list of findings for this reminder.
S RITEM=D0
D BLDFLST(RITEM,.FL)
;
;Get the cohort logic string.
S LOGSTR=$G(^PXD(811.9,RITEM,30))
;Otherwise use internal cohort logic
I LOGSTR="" S LOGSTR=$G(^PXD(811.9,RITEM,31)),CUSTOM=0
E S CUSTOM=1
;
;Remove any (0)! and (1)& entries
S LOGSTR=$$REMOVE(LOGSTR)
;
;Break the logic string into an array using the Boolean operators
;and the comma as separators.
S SEP="'!&<>=,"
S NLOGLIN=$$STRARR(LOGSTR,SEP,.LARRAY)
;
;Print the cohort logic.
I CUSTOM W "Customized PATIENT COHORT LOGIC to see if the Reminder applies to a patient:"
E W "Default PATIENT COHORT LOGIC to see if the Reminder applies to a patient:"
S NPL=$$FMTARR(MAXLEN,NLOGLIN,.LARRAY,.PARRAY)
F IND=1:1:NPL W !,?1,PARRAY(IND)
;
;Expand the logic and print it.
D EXPAND(NLOGLIN,.LARRAY,.FL,"FI(",")")
S NPL=$$FMTARR(MAXLEN,NLOGLIN,.LARRAY,.PARRAY)
W !!,"Expanded Patient Cohort Logic:"
F IND=1:1:NPL W !,?1,PARRAY(IND)
;
;Get the resolution logic string.
S LOGSTR=$G(^PXD(811.9,RITEM,34))
;Otherwise use internal cohort logic
I LOGSTR="" S LOGSTR=$G(^PXD(811.9,RITEM,35)),CUSTOM=0
E S CUSTOM=1
;
;Remove any (0)! and (1)& entries
S LOGSTR=$$REMOVE(LOGSTR)
;
;Break the logic string into an array using the Boolean operators
;and the comma as separators.
S NLOGLIN=$$STRARR(LOGSTR,SEP,.LARRAY)
;
;Print the resolution logic.
W !!
I CUSTOM W "Customized RESOLUTION LOGIC defines findings that resolve the Reminder:"
E W "Default RESOLUTION LOGIC defines findings that resolve the Reminder:"
S NPL=$$FMTARR(MAXLEN,NLOGLIN,.LARRAY,.PARRAY)
F IND=1:1:NPL W !,?1,PARRAY(IND)
;
;Expand the logic and print it.
D EXPAND(NLOGLIN,.LARRAY,.FL,"FI(",")")
S NPL=$$FMTARR(MAXLEN,NLOGLIN,.LARRAY,.PARRAY)
W !!,"Expanded Resolution Logic:"
F IND=1:1:NPL W !,?1,PARRAY(IND)
;
;Display the custom date due string.
S CDUE=$G(^PXD(811.9,D0,45))
I CDUE="" Q
W !!,"Custom Date Due:"
W !," ",CDUE
D CDUE(CDUE,.FL,.NLOGLIN,.LARRAY)
S NPL=$$FMTARR(MAXLEN,NLOGLIN,.LARRAY,.PARRAY)
W !!,"Expanded Custom Date Due:"
F IND=1:1:NPL W !,?1,PARRAY(IND)
Q
;
;====================================================
DISLOGF(RITEM,FINDING,FL,PARRAY) ;Expand FUNCTION FINDING logic and
;return the result in PARRAY.
N ARGNUM,AT,FARG,FUN,FUNCTION,FUNSTR,IND,ISFUN,MAXLEN,LARRAY
N NAME,NLOGLIN,NPL,NUM,SEP,TEMP
S MAXLEN=72
K PARRAY
;Get the function string.
S FUNSTR=$G(^PXD(811.9,RITEM,25,FINDING,3))
I FUNSTR="" Q
;
;Establish the list of separators that can be used in the logic
;string and take it apart.
S SEP="'!&=><,()+-"
S NLOGLIN=$$STRARR(FUNSTR,SEP,.LARRAY)
;Replace argument numbers with the finding.
S FARG=0
F IND=1:1:NLOGLIN D
. S TEMP=LARRAY(IND)
. I TEMP="" Q
. S FUN=$P(TEMP,"(",1)
. S ISFUN=$S(FUN="":0,$D(^PXRMD(802.4,"B",FUN)):1,1:0)
. I ISFUN S FARG=1,FUNCTION=$TR(FUN,"_",""),ARGNUM=0 Q
. I FARG D
.. S NUM=+TEMP
.. S ARGNUM=ARGNUM+1
.. S AT=$$ARGTYPE^PXRMFFAT(FUNCTION,ARGNUM)
.. I AT="F" D
... S NAME=$S($D(FL(NUM)):FL(NUM),1:"???")
... S LARRAY(IND)=$$STRREP^PXRMUTIL(LARRAY(IND),NUM,NAME)
..E S LARRAY(IND)=TEMP
. I TEMP[")" S FARG=0
;Format the array for printing.
S NPL=$$FMTARR(MAXLEN,NLOGLIN,.LARRAY,.PARRAY)
Q
;
;====================================================
EXPAND(NL,ARRAY,FL,LT,RT) ;Insert findings in FI(n) format. Each element
;of ARRAY will contain no more than one FI.
N FIE,FIS,FNUM,LEN,NAME,STRING
F IND=1:1:NL D
. S STRING=ARRAY(IND)
. S FIS=$F(STRING,LT)
. I FIS=0 Q
. S LEN=$L(STRING)
. S FIE=$F(STRING,RT,FIS)-2
. S FNUM=$E(STRING,FIS,FIE)
. S NAME=$S($D(FL(FNUM)):FL(FNUM),1:"???")
. S ARRAY(IND)=$E(STRING,1,FIS-1)_NAME_$E(STRING,FIE+1,LEN)
Q
;
;====================================================
FMTARR(MAXLEN,NE,INARRAY,OUTARRAY) ;Load the output array.
N IC,LINNUM,SLEN
K OUTARRY
S OUTARRAY(1)=""
S LINNUM=1
F IC=1:1:NE D
. S SLEN=$L(OUTARRAY(LINNUM))+$L(INARRAY(IC))
. I SLEN>MAXLEN D
.. S LINNUM=LINNUM+1
.. S OUTARRAY(LINNUM)=INARRAY(IC)
. E S OUTARRAY(LINNUM)=OUTARRAY(LINNUM)_INARRAY(IC)
Q LINNUM
;
;====================================================
STRARR(STRING,SEP,ARRAY) ;Break STRING into an array using SEP.
N CHAR,IC,LINNUM,NE,SLEN,TEMP
K OUTARRAY
;Break string into pieces using SEP.
S SLEN=$L(STRING)
S LINNUM=0,TEMP=""
F IC=1:1:SLEN D
. S CHAR=$E(STRING,IC,IC)
. S TEMP=TEMP_CHAR
. I SEP[CHAR D
.. S LINNUM=LINNUM+1
.. S ARRAY(LINNUM)=TEMP
.. S TEMP=""
S LINNUM=LINNUM+1
S ARRAY(LINNUM)=TEMP
Q LINNUM
;
;====================================================
REMOVE(STRING) ;Remove leading (n) entries
I ($E(STRING,1,4)="(0)!")!($E(STRING,1,4)="(1)&") S $E(STRING,1,4)=""
Q STRING
;
PXRMPTL ;SLC/DLT,PKR,PJH - Print Clinical Reminders logic ;02/04/2011
+1 ;;2.0;CLINICAL REMINDERS;**4,12,18**;Feb 04, 2005;Build 152
+2 ;
+3 ;====================================================
BLDFLST(RITEM,FL) ;Build the list of findings defined for this reminder.
+1 NEW IC,TEMP,GLOB,SUB,NAME
+2 ;Build a list of findings.
+3 SET IC=0
+4 FOR
SET IC=$ORDER(^PXD(811.9,RITEM,20,IC))
IF +IC=0
QUIT
Begin DoDot:1
+5 SET TEMP=$PIECE(^PXD(811.9,RITEM,20,IC,0),U)
+6 SET GLOB=$PIECE(TEMP,";",2)
SET SUB=$PIECE(TEMP,";")
+7 SET NAME=$SELECT(GLOB="":"???",1:$PIECE($GET(@(U_GLOB_SUB_",0)")),U))
+8 SET FL(IC)=NAME
End DoDot:1
+9 QUIT
+10 ;
+11 ;====================================================
CDUE(CDUE,FL,NL,ARRAY) ;Expand the custom date due string into ARRAY.
+1 NEW FILIST,FREQLIST,FUNCTION,IND,OPLIST,NARGS
+2 DO PARSE^PXRMCDUE(CDUE,.FUNCTION,.NARGS,.FILIST,.FREQLIST,.OPLIST)
+3 SET ARRAY(1)=FUNCTION_"("
SET NL=1
+4 FOR IND=1:1:NARGS
Begin DoDot:1
+5 SET NL=NL+1
+6 SET ARRAY(NL)=FL(FILIST(IND))_OPLIST(IND)_FREQLIST(IND)
+7 IF IND<NARGS
SET ARRAY(NL)=ARRAY(NL)_", "
End DoDot:1
+8 SET NL=NL+1
SET ARRAY(NL)=")"
+9 QUIT
+10 ;
+11 ;====================================================
COHORT(DA) ;
+1 NEW ARRAY,CNT,LINE,NODE,NLINES,OUTPUT
+2 FOR NODE=60,61,65,66,70,71,75,76
IF $DATA(^PXD(811.9,DA,NODE))>0
Begin DoDot:1
+3 IF NODE=60
WRITE !,"General Patient Cohort Found Text:"
+4 IF NODE=61
WRITE !,"General Patient Cohort Not Found Text:"
+5 IF NODE=65
WRITE !,"General Resolution Found Text:"
+6 IF NODE=66
WRITE !,"General Resolution Not Found Text:"
+7 IF NODE=70
WRITE !,"Summary Patient Cohort Found Text:"
+8 IF NODE=71
WRITE !,"Summary Patient Cohort Not Found Text:"
+9 IF NODE=75
WRITE !,"Summary Resolution Found Text:"
+10 IF NODE=76
WRITE !,"Summary Resolution Not Found Text:"
+11 SET (CNT,LINE)=0
FOR
SET LINE=$ORDER(^PXD(811.9,DA,NODE,LINE))
IF LINE=""
QUIT
Begin DoDot:2
+12 SET CNT=CNT+1
SET ARRAY(CNT)=$GET(^PXD(811.9,DA,NODE,LINE,0))
End DoDot:2
+13 IF $DATA(ARRAY)>0
DO FORMAT^PXRMTEXT(5,78,CNT,.ARRAY,.NLINES,.OUTPUT)
+14 IF NLINES>0
FOR CNT=1:1:NLINES
WRITE !,OUTPUT(CNT)
+15 WRITE !
End DoDot:1
+16 QUIT
+17 ;
+18 ;====================================================
DISLOG ;Display the patient cohort, resolution logic, and custom date due.
+1 ;Determine if this is a default adhoc logic or user modified logic
+2 NEW CDUE,CUSTOM,FL,IND,LARRAY,LOGSTR,MAXLEN,NLOGLIN,NPL
+3 NEW PARRAY,RITEM,SEP
+4 SET MAXLEN=72
+5 ;Build the list of findings for this reminder.
+6 SET RITEM=D0
+7 DO BLDFLST(RITEM,.FL)
+8 ;
+9 ;Get the cohort logic string.
+10 SET LOGSTR=$GET(^PXD(811.9,RITEM,30))
+11 ;Otherwise use internal cohort logic
+12 IF LOGSTR=""
SET LOGSTR=$GET(^PXD(811.9,RITEM,31))
SET CUSTOM=0
+13 IF '$TEST
SET CUSTOM=1
+14 ;
+15 ;Remove any (0)! and (1)& entries
+16 SET LOGSTR=$$REMOVE(LOGSTR)
+17 ;
+18 ;Break the logic string into an array using the Boolean operators
+19 ;and the comma as separators.
+20 SET SEP="'!&<>=,"
+21 SET NLOGLIN=$$STRARR(LOGSTR,SEP,.LARRAY)
+22 ;
+23 ;Print the cohort logic.
+24 IF CUSTOM
WRITE "Customized PATIENT COHORT LOGIC to see if the Reminder applies to a patient:"
+25 IF '$TEST
WRITE "Default PATIENT COHORT LOGIC to see if the Reminder applies to a patient:"
+26 SET NPL=$$FMTARR(MAXLEN,NLOGLIN,.LARRAY,.PARRAY)
+27 FOR IND=1:1:NPL
WRITE !,?1,PARRAY(IND)
+28 ;
+29 ;Expand the logic and print it.
+30 DO EXPAND(NLOGLIN,.LARRAY,.FL,"FI(",")")
+31 SET NPL=$$FMTARR(MAXLEN,NLOGLIN,.LARRAY,.PARRAY)
+32 WRITE !!,"Expanded Patient Cohort Logic:"
+33 FOR IND=1:1:NPL
WRITE !,?1,PARRAY(IND)
+34 ;
+35 ;Get the resolution logic string.
+36 SET LOGSTR=$GET(^PXD(811.9,RITEM,34))
+37 ;Otherwise use internal cohort logic
+38 IF LOGSTR=""
SET LOGSTR=$GET(^PXD(811.9,RITEM,35))
SET CUSTOM=0
+39 IF '$TEST
SET CUSTOM=1
+40 ;
+41 ;Remove any (0)! and (1)& entries
+42 SET LOGSTR=$$REMOVE(LOGSTR)
+43 ;
+44 ;Break the logic string into an array using the Boolean operators
+45 ;and the comma as separators.
+46 SET NLOGLIN=$$STRARR(LOGSTR,SEP,.LARRAY)
+47 ;
+48 ;Print the resolution logic.
+49 WRITE !!
+50 IF CUSTOM
WRITE "Customized RESOLUTION LOGIC defines findings that resolve the Reminder:"
+51 IF '$TEST
WRITE "Default RESOLUTION LOGIC defines findings that resolve the Reminder:"
+52 SET NPL=$$FMTARR(MAXLEN,NLOGLIN,.LARRAY,.PARRAY)
+53 FOR IND=1:1:NPL
WRITE !,?1,PARRAY(IND)
+54 ;
+55 ;Expand the logic and print it.
+56 DO EXPAND(NLOGLIN,.LARRAY,.FL,"FI(",")")
+57 SET NPL=$$FMTARR(MAXLEN,NLOGLIN,.LARRAY,.PARRAY)
+58 WRITE !!,"Expanded Resolution Logic:"
+59 FOR IND=1:1:NPL
WRITE !,?1,PARRAY(IND)
+60 ;
+61 ;Display the custom date due string.
+62 SET CDUE=$GET(^PXD(811.9,D0,45))
+63 IF CDUE=""
QUIT
+64 WRITE !!,"Custom Date Due:"
+65 WRITE !," ",CDUE
+66 DO CDUE(CDUE,.FL,.NLOGLIN,.LARRAY)
+67 SET NPL=$$FMTARR(MAXLEN,NLOGLIN,.LARRAY,.PARRAY)
+68 WRITE !!,"Expanded Custom Date Due:"
+69 FOR IND=1:1:NPL
WRITE !,?1,PARRAY(IND)
+70 QUIT
+71 ;
+72 ;====================================================
DISLOGF(RITEM,FINDING,FL,PARRAY) ;Expand FUNCTION FINDING logic and
+1 ;return the result in PARRAY.
+2 NEW ARGNUM,AT,FARG,FUN,FUNCTION,FUNSTR,IND,ISFUN,MAXLEN,LARRAY
+3 NEW NAME,NLOGLIN,NPL,NUM,SEP,TEMP
+4 SET MAXLEN=72
+5 KILL PARRAY
+6 ;Get the function string.
+7 SET FUNSTR=$GET(^PXD(811.9,RITEM,25,FINDING,3))
+8 IF FUNSTR=""
QUIT
+9 ;
+10 ;Establish the list of separators that can be used in the logic
+11 ;string and take it apart.
+12 SET SEP="'!&=><,()+-"
+13 SET NLOGLIN=$$STRARR(FUNSTR,SEP,.LARRAY)
+14 ;Replace argument numbers with the finding.
+15 SET FARG=0
+16 FOR IND=1:1:NLOGLIN
Begin DoDot:1
+17 SET TEMP=LARRAY(IND)
+18 IF TEMP=""
QUIT
+19 SET FUN=$PIECE(TEMP,"(",1)
+20 SET ISFUN=$SELECT(FUN="":0,$DATA(^PXRMD(802.4,"B",FUN)):1,1:0)
+21 IF ISFUN
SET FARG=1
SET FUNCTION=$TRANSLATE(FUN,"_","")
SET ARGNUM=0
QUIT
+22 IF FARG
Begin DoDot:2
+23 SET NUM=+TEMP
+24 SET ARGNUM=ARGNUM+1
+25 SET AT=$$ARGTYPE^PXRMFFAT(FUNCTION,ARGNUM)
+26 IF AT="F"
Begin DoDot:3
+27 SET NAME=$SELECT($DATA(FL(NUM)):FL(NUM),1:"???")
+28 SET LARRAY(IND)=$$STRREP^PXRMUTIL(LARRAY(IND),NUM,NAME)
End DoDot:3
+29 IF '$TEST
SET LARRAY(IND)=TEMP
End DoDot:2
+30 IF TEMP[")"
SET FARG=0
End DoDot:1
+31 ;Format the array for printing.
+32 SET NPL=$$FMTARR(MAXLEN,NLOGLIN,.LARRAY,.PARRAY)
+33 QUIT
+34 ;
+35 ;====================================================
EXPAND(NL,ARRAY,FL,LT,RT) ;Insert findings in FI(n) format. Each element
+1 ;of ARRAY will contain no more than one FI.
+2 NEW FIE,FIS,FNUM,LEN,NAME,STRING
+3 FOR IND=1:1:NL
Begin DoDot:1
+4 SET STRING=ARRAY(IND)
+5 SET FIS=$FIND(STRING,LT)
+6 IF FIS=0
QUIT
+7 SET LEN=$LENGTH(STRING)
+8 SET FIE=$FIND(STRING,RT,FIS)-2
+9 SET FNUM=$EXTRACT(STRING,FIS,FIE)
+10 SET NAME=$SELECT($DATA(FL(FNUM)):FL(FNUM),1:"???")
+11 SET ARRAY(IND)=$EXTRACT(STRING,1,FIS-1)_NAME_$EXTRACT(STRING,FIE+1,LEN)
End DoDot:1
+12 QUIT
+13 ;
+14 ;====================================================
FMTARR(MAXLEN,NE,INARRAY,OUTARRAY) ;Load the output array.
+1 NEW IC,LINNUM,SLEN
+2 KILL OUTARRY
+3 SET OUTARRAY(1)=""
+4 SET LINNUM=1
+5 FOR IC=1:1:NE
Begin DoDot:1
+6 SET SLEN=$LENGTH(OUTARRAY(LINNUM))+$LENGTH(INARRAY(IC))
+7 IF SLEN>MAXLEN
Begin DoDot:2
+8 SET LINNUM=LINNUM+1
+9 SET OUTARRAY(LINNUM)=INARRAY(IC)
End DoDot:2
+10 IF '$TEST
SET OUTARRAY(LINNUM)=OUTARRAY(LINNUM)_INARRAY(IC)
End DoDot:1
+11 QUIT LINNUM
+12 ;
+13 ;====================================================
STRARR(STRING,SEP,ARRAY) ;Break STRING into an array using SEP.
+1 NEW CHAR,IC,LINNUM,NE,SLEN,TEMP
+2 KILL OUTARRAY
+3 ;Break string into pieces using SEP.
+4 SET SLEN=$LENGTH(STRING)
+5 SET LINNUM=0
SET TEMP=""
+6 FOR IC=1:1:SLEN
Begin DoDot:1
+7 SET CHAR=$EXTRACT(STRING,IC,IC)
+8 SET TEMP=TEMP_CHAR
+9 IF SEP[CHAR
Begin DoDot:2
+10 SET LINNUM=LINNUM+1
+11 SET ARRAY(LINNUM)=TEMP
+12 SET TEMP=""
End DoDot:2
End DoDot:1
+13 SET LINNUM=LINNUM+1
+14 SET ARRAY(LINNUM)=TEMP
+15 QUIT LINNUM
+16 ;
+17 ;====================================================
REMOVE(STRING) ;Remove leading (n) entries
+1 IF ($EXTRACT(STRING,1,4)="(0)!")!($EXTRACT(STRING,1,4)="(1)&")
SET $EXTRACT(STRING,1,4)=""
+2 QUIT STRING
+3 ;
