PXRMDRSG ;SLC/AGP - DIALOG RESULTS LOADER ;09/27/2018
;;2.0;CLINICAL REMINDERS;**6,45**;Feb 04, 2005;Build 566
;
;Build score related P/N text from score and result group
;
MHDLL(ORY,RESULTS,SCORES,DFN,DIEN) ;
N ARY,CNT,INSERT,NODE,RESULT,SCORE,SCALENUM
N OCNT,IMULT,MULT
S OCNT=0,IMULT=0,MULT=0
S CNT=0 F S CNT=$O(SCORES(CNT)) Q:CNT'>0 D
.S NODE=$G(SCORES(CNT)) Q:NODE=""
.S ARY($P(NODE,"~"))=$P(NODE,"~",2)
S CNT=0 F S CNT=$O(RESULTS(CNT)) Q:CNT'>0 D
.S RESULT=$G(RESULTS(CNT)) Q:RESULT=""
.I $P($G(^PXRMD(801.41,RESULT,50)),U,1)="" Q
.S SCALENUM=$P($G(^PXRMD(801.41,RESULT,50)),U,2) Q:SCALENUM=""
.S SCORE=$G(ARY(SCALENUM)) Q:SCORE=""
.S INSERT("SCORE")=SCORE
.D TEXT(.ORY,.OCNT,IMULT,.MULT,SCORE)
Q
;
OUT(DATA) ;Display element details
N DITEM S DITEM=$P(DATA,U,2) Q:'DITEM
W $P($G(^PXRMD(801.41,DITEM,0)),U)
W !,$J("Element Condition: ",19)
W $TR($P($G(^PXRMD(801.41,DITEM,0)),U,13),"~"," ")
W !,$J("Element text:",17)
;Get progress note text if defined
N SUB,TEXT S SUB=0
F S SUB=$O(^PXRMD(801.41,DITEM,35,SUB)) Q:'SUB D
.S TEXT=$G(^PXRMD(801.41,DITEM,35,SUB,0)) W !,?5,TEXT
W !,$J("Informational text:",17)
N SUB,TEXT S SUB=0
F S SUB=$O(^PXRMD(801.41,DITEM,25,SUB)) Q:'SUB D
.S TEXT=$G(^PXRMD(801.41,DITEM,25,SUB,0)) W !,?5,TEXT
Q
;
TEXT(ORY,OCNT,IMULT,MULT,SCORE) ;
;Load dialog results into ORY array
N DATA,DCON,DITEM,DSEQ,DSUB,DTYP,INS,SEP,TEXT
N INFOTEXT
;S SCORE=$G(INSERT("SCORE")) Q:SCORE=""
;Get the result elements
S DSEQ=0
F S DSEQ=$O(^PXRMD(801.41,RESULT,10,"B",DSEQ)) Q:'DSEQ D
.S DSUB=$O(^PXRMD(801.41,RESULT,10,"B",DSEQ,"")) Q:'DSUB
.S DITEM=$P($G(^PXRMD(801.41,RESULT,10,DSUB,0)),U,2) Q:'DITEM
.;Get the result element
.S DTYP=$P($G(^PXRMD(801.41,DITEM,0)),U,4) Q:DTYP'="T"
.;Get the result element condition
.S DCON=$P($G(^PXRMD(801.41,DITEM,0)),U,13)
.;Skip if condition not satisfied
.I DCON'="" S DCON=$TR(DCON,"~"," ") Q:'$$TRUE(SCORE,DCON,DFN)
.;Get progress note/Info text if defined
.N LAST,NULL,SUB,TEXT S SUB=0,LAST=0
.S INFOTEXT=""
.F S SUB=$O(^PXRMD(801.41,DITEM,25,SUB)) Q:'SUB D
..S TEXT=$G(^PXRMD(801.41,DITEM,25,SUB,0))
..I INFOTEXT="" S INFOTEXT="[INFOTEXT]"
..S NULL=0 I ($E(TEXT)=" ")!(TEXT="") S NULL=1
..;Add line breaks if is or preceded by blank line or starts with space
..I ('NULL),LAST S TEXT="<br>"_TEXT
..S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
..S LAST=0 I NULL S TEXT="<br>"_TEXT,LAST=1
..I MULT=1,SUB=1,$E(TEXT,1,4)'="<br>" S TEXT="<br>"_TEXT
..S TEXT=$$STRREP^PXRMUTIL(TEXT,"<br>",U)
..I SUB=1,IMULT=1 S TEXT=U_TEXT
..S OCNT=OCNT+1,ORY(OCNT)=INFOTEXT_TEXT
..I IMULT=0,OCNT>0 S IMULT=1
..;S INFOTEXT=INFOTEXT_TEXT
.;
.S LAST=0,NULL=0,SUB=0
.F S SUB=$O(^PXRMD(801.41,DITEM,35,SUB)) Q:'SUB D
..;Insert score into text (if neccessary)
..S TEXT=$G(^PXRMD(801.41,DITEM,35,SUB,0))
..S NULL=0 I ($E(TEXT)=" ")!(TEXT="") S NULL=1
..;Add line breaks if is or preceded by blank line or starts with space
..I ('NULL),LAST S TEXT="<br>"_TEXT
..S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
..S LAST=0 I NULL S TEXT="<br>"_TEXT,LAST=1
..I MULT=1,SUB=1,$E(TEXT,1,4)'="<br>" S TEXT="<br>"_TEXT
..;Check for inserts - note there may be embedded TIU markers too
..N INS
..S INS=""
..F S INS=$O(INSERT(INS)) Q:INS="" D
...S SEP="|"_INS_"|" I '$F(TEXT,SEP) Q
...S TEXT=$P(TEXT,SEP)_$G(INSERT(INS))_$P(TEXT,SEP,2,99)
..S OCNT=OCNT+1,ORY(OCNT)=TEXT
..I MULT=0,OCNT>0 S MULT=1
.;I $G(INFOTEXT)'="" S OCNT=OCNT+1,ORY(OCNT)=INFOTEXT
.D CHECKLNK(DIEN,RESULT,DITEM,.ORY,.OCNT)
Q
;
TRUE(V,COND,DFN) ; Check if value meets element condition
N RESULT,SEX
I COND["SEX" D Q RESULT
. S RESULT=0
. S SEX=$P($G(^DPT(DFN,0)),U,2)
. X COND I S RESULT=1
X COND I Q 1
Q 0
;
CHECKLNK(DIEN,RG,RE,ORY,OCNT) ;
N ACT,FUNC,LIEN,LINK,LTYPE,NODE,NUM,NVALUE,OVALUE,OK,RESULT,RGNUM,INPUTS
S RGNUM=$O(^PXRMD(801.41,DIEN,51,"B",RG,"")) I RGNUM'>0 Q
S NUM=$O(^PXRMD(801.41,DIEN,51,RGNUM,1,"B",RE,"")) I NUM'>0 Q
S NODE=$G(^PXRMD(801.41,DIEN,51,RGNUM,1,NUM,0))
;S LIEN=$P(NODE,U,2),LTYPE=$P(NODE,U,3),FUNC=$G(^PXRMD(801.41,DIEN,51,RGNUM,1,NUM,1))
S LINK=$P(NODE,U,2) I LINK'>0 Q
D GETLINK^PXRMDLLB(LINK,.LIEN,.LTYPE,.FUNC,.ACT)
Q:LIEN'>0 Q:LTYPE="" Q:ACT=""
I FUNC'="" D Q
.S NUM=0 F S NUM=$O(^PXRMD(801.48,LINK,2,NUM)) Q:NUM'>0 D
..S NODE=$G(^PXRMD(801.48,LINK,2,NUM,0)),SUB=$P(NODE,U),VAL=$P(NODE,U,2) Q:SUB="" Q:VAL=""
..S INPUTS(SUB)=VAL
.S RESULT="",RTN=$P($G(^PXRMD(801.47,FUNC,0)),U,2,3) Q:$P(RTN,U)="" Q:$P(RTN,U,2)=""
.S NVALUE="",OVALUE=""
.S TEMP="S RET=$$"_RTN_"(.RESULT,DFN,NVALUE,OVALUE,.INPUTS)"
.X TEMP
.I RESULT'=1 Q
.S OCNT=OCNT+1,ORY(OCNT)="[LINK]"_U_LIEN_U_LTYPE_U_ACT
;X FUNC
S OCNT=OCNT+1,ORY(OCNT)="[LINK]"_U_LIEN_U_LTYPE_U_ACT
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMDRSG 4829 printed Sep 23, 2025@19:20:17 Page 2
PXRMDRSG ;SLC/AGP - DIALOG RESULTS LOADER ;09/27/2018
+1 ;;2.0;CLINICAL REMINDERS;**6,45**;Feb 04, 2005;Build 566
+2 ;
+3 ;Build score related P/N text from score and result group
+4 ;
MHDLL(ORY,RESULTS,SCORES,DFN,DIEN) ;
+1 NEW ARY,CNT,INSERT,NODE,RESULT,SCORE,SCALENUM
+2 NEW OCNT,IMULT,MULT
+3 SET OCNT=0
SET IMULT=0
SET MULT=0
+4 SET CNT=0
FOR
SET CNT=$ORDER(SCORES(CNT))
if CNT'>0
QUIT
Begin DoDot:1
+5 SET NODE=$GET(SCORES(CNT))
if NODE=""
QUIT
+6 SET ARY($PIECE(NODE,"~"))=$PIECE(NODE,"~",2)
End DoDot:1
+7 SET CNT=0
FOR
SET CNT=$ORDER(RESULTS(CNT))
if CNT'>0
QUIT
Begin DoDot:1
+8 SET RESULT=$GET(RESULTS(CNT))
if RESULT=""
QUIT
+9 IF $PIECE($GET(^PXRMD(801.41,RESULT,50)),U,1)=""
QUIT
+10 SET SCALENUM=$PIECE($GET(^PXRMD(801.41,RESULT,50)),U,2)
if SCALENUM=""
QUIT
+11 SET SCORE=$GET(ARY(SCALENUM))
if SCORE=""
QUIT
+12 SET INSERT("SCORE")=SCORE
+13 DO TEXT(.ORY,.OCNT,IMULT,.MULT,SCORE)
End DoDot:1
+14 QUIT
+15 ;
OUT(DATA) ;Display element details
+1 NEW DITEM
SET DITEM=$PIECE(DATA,U,2)
if 'DITEM
QUIT
+2 WRITE $PIECE($GET(^PXRMD(801.41,DITEM,0)),U)
+3 WRITE !,$JUSTIFY("Element Condition: ",19)
+4 WRITE $TRANSLATE($PIECE($GET(^PXRMD(801.41,DITEM,0)),U,13),"~"," ")
+5 WRITE !,$JUSTIFY("Element text:",17)
+6 ;Get progress note text if defined
+7 NEW SUB,TEXT
SET SUB=0
+8 FOR
SET SUB=$ORDER(^PXRMD(801.41,DITEM,35,SUB))
if 'SUB
QUIT
Begin DoDot:1
+9 SET TEXT=$GET(^PXRMD(801.41,DITEM,35,SUB,0))
WRITE !,?5,TEXT
End DoDot:1
+10 WRITE !,$JUSTIFY("Informational text:",17)
+11 NEW SUB,TEXT
SET SUB=0
+12 FOR
SET SUB=$ORDER(^PXRMD(801.41,DITEM,25,SUB))
if 'SUB
QUIT
Begin DoDot:1
+13 SET TEXT=$GET(^PXRMD(801.41,DITEM,25,SUB,0))
WRITE !,?5,TEXT
End DoDot:1
+14 QUIT
+15 ;
TEXT(ORY,OCNT,IMULT,MULT,SCORE) ;
+1 ;Load dialog results into ORY array
+2 NEW DATA,DCON,DITEM,DSEQ,DSUB,DTYP,INS,SEP,TEXT
+3 NEW INFOTEXT
+4 ;S SCORE=$G(INSERT("SCORE")) Q:SCORE=""
+5 ;Get the result elements
+6 SET DSEQ=0
+7 FOR
SET DSEQ=$ORDER(^PXRMD(801.41,RESULT,10,"B",DSEQ))
if 'DSEQ
QUIT
Begin DoDot:1
+8 SET DSUB=$ORDER(^PXRMD(801.41,RESULT,10,"B",DSEQ,""))
if 'DSUB
QUIT
+9 SET DITEM=$PIECE($GET(^PXRMD(801.41,RESULT,10,DSUB,0)),U,2)
if 'DITEM
QUIT
+10 ;Get the result element
+11 SET DTYP=$PIECE($GET(^PXRMD(801.41,DITEM,0)),U,4)
if DTYP'="T"
QUIT
+12 ;Get the result element condition
+13 SET DCON=$PIECE($GET(^PXRMD(801.41,DITEM,0)),U,13)
+14 ;Skip if condition not satisfied
+15 IF DCON'=""
SET DCON=$TRANSLATE(DCON,"~"," ")
if '$$TRUE(SCORE,DCON,DFN)
QUIT
+16 ;Get progress note/Info text if defined
+17 NEW LAST,NULL,SUB,TEXT
SET SUB=0
SET LAST=0
+18 SET INFOTEXT=""
+19 FOR
SET SUB=$ORDER(^PXRMD(801.41,DITEM,25,SUB))
if 'SUB
QUIT
Begin DoDot:2
+20 SET TEXT=$GET(^PXRMD(801.41,DITEM,25,SUB,0))
+21 IF INFOTEXT=""
SET INFOTEXT="[INFOTEXT]"
+22 SET NULL=0
IF ($EXTRACT(TEXT)=" ")!(TEXT="")
SET NULL=1
+23 ;Add line breaks if is or preceded by blank line or starts with space
+24 IF ('NULL)
IF LAST
SET TEXT="<br>"_TEXT
+25 SET TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
+26 SET LAST=0
IF NULL
SET TEXT="<br>"_TEXT
SET LAST=1
+27 IF MULT=1
IF SUB=1
IF $EXTRACT(TEXT,1,4)'="<br>"
SET TEXT="<br>"_TEXT
+28 SET TEXT=$$STRREP^PXRMUTIL(TEXT,"<br>",U)
+29 IF SUB=1
IF IMULT=1
SET TEXT=U_TEXT
+30 SET OCNT=OCNT+1
SET ORY(OCNT)=INFOTEXT_TEXT
+31 IF IMULT=0
IF OCNT>0
SET IMULT=1
+32 ;S INFOTEXT=INFOTEXT_TEXT
End DoDot:2
+33 ;
+34 SET LAST=0
SET NULL=0
SET SUB=0
+35 FOR
SET SUB=$ORDER(^PXRMD(801.41,DITEM,35,SUB))
if 'SUB
QUIT
Begin DoDot:2
+36 ;Insert score into text (if neccessary)
+37 SET TEXT=$GET(^PXRMD(801.41,DITEM,35,SUB,0))
+38 SET NULL=0
IF ($EXTRACT(TEXT)=" ")!(TEXT="")
SET NULL=1
+39 ;Add line breaks if is or preceded by blank line or starts with space
+40 IF ('NULL)
IF LAST
SET TEXT="<br>"_TEXT
+41 SET TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
+42 SET LAST=0
IF NULL
SET TEXT="<br>"_TEXT
SET LAST=1
+43 IF MULT=1
IF SUB=1
IF $EXTRACT(TEXT,1,4)'="<br>"
SET TEXT="<br>"_TEXT
+44 ;Check for inserts - note there may be embedded TIU markers too
+45 NEW INS
+46 SET INS=""
+47 FOR
SET INS=$ORDER(INSERT(INS))
if INS=""
QUIT
Begin DoDot:3
+48 SET SEP="|"_INS_"|"
IF '$FIND(TEXT,SEP)
QUIT
+49 SET TEXT=$PIECE(TEXT,SEP)_$GET(INSERT(INS))_$PIECE(TEXT,SEP,2,99)
End DoDot:3
+50 SET OCNT=OCNT+1
SET ORY(OCNT)=TEXT
+51 IF MULT=0
IF OCNT>0
SET MULT=1
End DoDot:2
+52 ;I $G(INFOTEXT)'="" S OCNT=OCNT+1,ORY(OCNT)=INFOTEXT
+53 DO CHECKLNK(DIEN,RESULT,DITEM,.ORY,.OCNT)
End DoDot:1
+54 QUIT
+55 ;
TRUE(V,COND,DFN) ; Check if value meets element condition
+1 NEW RESULT,SEX
+2 IF COND["SEX"
Begin DoDot:1
+3 SET RESULT=0
+4 SET SEX=$PIECE($GET(^DPT(DFN,0)),U,2)
+5 XECUTE COND
IF $TEST
SET RESULT=1
End DoDot:1
QUIT RESULT
+6 XECUTE COND
IF $TEST
QUIT 1
+7 QUIT 0
+8 ;
CHECKLNK(DIEN,RG,RE,ORY,OCNT) ;
+1 NEW ACT,FUNC,LIEN,LINK,LTYPE,NODE,NUM,NVALUE,OVALUE,OK,RESULT,RGNUM,INPUTS
+2 SET RGNUM=$ORDER(^PXRMD(801.41,DIEN,51,"B",RG,""))
IF RGNUM'>0
QUIT
+3 SET NUM=$ORDER(^PXRMD(801.41,DIEN,51,RGNUM,1,"B",RE,""))
IF NUM'>0
QUIT
+4 SET NODE=$GET(^PXRMD(801.41,DIEN,51,RGNUM,1,NUM,0))
+5 ;S LIEN=$P(NODE,U,2),LTYPE=$P(NODE,U,3),FUNC=$G(^PXRMD(801.41,DIEN,51,RGNUM,1,NUM,1))
+6 SET LINK=$PIECE(NODE,U,2)
IF LINK'>0
QUIT
+7 DO GETLINK^PXRMDLLB(LINK,.LIEN,.LTYPE,.FUNC,.ACT)
+8 if LIEN'>0
QUIT
if LTYPE=""
QUIT
if ACT=""
QUIT
+9 IF FUNC'=""
Begin DoDot:1
+10 SET NUM=0
FOR
SET NUM=$ORDER(^PXRMD(801.48,LINK,2,NUM))
if NUM'>0
QUIT
Begin DoDot:2
+11 SET NODE=$GET(^PXRMD(801.48,LINK,2,NUM,0))
SET SUB=$PIECE(NODE,U)
SET VAL=$PIECE(NODE,U,2)
if SUB=""
QUIT
if VAL=""
QUIT
+12 SET INPUTS(SUB)=VAL
End DoDot:2
+13 SET RESULT=""
SET RTN=$PIECE($GET(^PXRMD(801.47,FUNC,0)),U,2,3)
if $PIECE(RTN,U)=""
QUIT
if $PIECE(RTN,U,2)=""
QUIT
+14 SET NVALUE=""
SET OVALUE=""
+15 SET TEMP="S RET=$$"_RTN_"(.RESULT,DFN,NVALUE,OVALUE,.INPUTS)"
+16 XECUTE TEMP
+17 IF RESULT'=1
QUIT
+18 SET OCNT=OCNT+1
SET ORY(OCNT)="[LINK]"_U_LIEN_U_LTYPE_U_ACT
End DoDot:1
QUIT
+19 ;X FUNC
+20 SET OCNT=OCNT+1
SET ORY(OCNT)="[LINK]"_U_LIEN_U_LTYPE_U_ACT
+21 QUIT
+22 ;
