PXRMDLR ;SLC/PJH - DIALOG RESULTS LOADER ;05/15/2007
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
;
;Build score related P/N text from score and result group
;
;If not found
START(ORY,RESULT,ORES) ;
I '$G(RESULT) S ORY(1)="-1^no results for this test" Q
;
N ARRAY,ERROR,INSERT,OK,SCORE,SUB,YT,X
;
I RESULT["~" S RESULT=$P(RESULT,"~")
S ERROR=0
;
;Get score using API
K ^TMP($J,"YSCOR")
I ORES("CODE")'="DOM80" D Q:ERROR
.M YT=ORES
.F X=1:1:$L(YT("R1")) I $E(YT("R1"),X)'="X" S YT(X)=X_U_$E(YT("R1"),X)
.K YT("R1")
.D CHECKCR^YTQPXRM4(.ARRAY,.YT)
.S OK=0
.;D PREVIEW^YTAPI4(.ARRAY,.YT)
.I ^TMP($J,"YSCOR",1)'="[DATA]" S ORY(1)="-1^"_^TMP($J,"YSCOR",1)_^TMP($J,"YSCOD",2),ERROR=1 Q
.;I ARRAY(1)'="[DATA]" S ORY(1)="-1^"_ARRAY(1)_ARRAY(2),ERROR=1 Q
.I $P($G(^TMP($J,"YSCOR",2)),"=",2)'="" S SCORE=$P($G(^TMP($J,"YSCOR",2)),"=",2),OK=1
.;S SUB=0,OK=0
.;F S SUB=$O(ARRAY(SUB)) Q:'SUB D Q:OK
.;.I $P(ARRAY(SUB),U)="S1" S SCORE=$P(ARRAY(SUB),U,3),OK=1
.I 'OK S ORY(1)="-1^[ERROR] no score returned",ERROR=1 Q
;
;Except for DOM80
I ORES("CODE")="DOM80" D
.I $E(ORES("R1"))="Y" S SCORE=1 Q
.I $E(ORES("R1"),2,3)="YY",($E(ORES("R1"),4)>1) S SCORE=1 Q
.S SCORE=0
;
S DFN=$G(ORES("DFN"))
S INSERT("SCORE")=SCORE
;
;For AIMS special formatting is required
I ORES("CODE")="AIMS" D
.N CNT,LITS,RESP,SUM
.S LITS(0)="none",LITS(1)="minimal",LITS(2)="mild",LITS(3)="moderate"
.S LITS(4)="severe",SUM(2)=0,SUM(3)=0,SUM(4)=0
.F CNT=1:1 S RESP=$E(ORES("R1"),CNT) Q:RESP="" D
..S INSERT("R"_CNT)=$G(LITS(RESP))
..I (CNT<8),(234[RESP) S SUM(RESP)=SUM(RESP)+1
.F CNT=2,3,4 S INSERT("SUM"_CNT)=SUM(CNT)
;
TEXT ;
I RESULT["~" S RESULT=$P(RESULT,"~")
;Load dialog results into ORY array
N DATA,DCON,DITEM,DSEQ,DSUB,DTYP,INS,SEP,TEXT
;Get the result elements
S DSEQ=0,OCNT=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 text if defined
.N LAST,NULL,SUB,TEXT S SUB=0,LAST=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
..;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)=7_U_TEXT
Q
;
MHDLL(ORES,RESULT,SCORE,DFN) ;
S INSERT("SCORE")=SCORE
D TEXT
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
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMDLR 3750 printed Jan 18, 2025@02:45:21 Page 2
PXRMDLR ;SLC/PJH - DIALOG RESULTS LOADER ;05/15/2007
+1 ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+2 ;
+3 ;Build score related P/N text from score and result group
+4 ;
+5 ;If not found
START(ORY,RESULT,ORES) ;
+1 IF '$GET(RESULT)
SET ORY(1)="-1^no results for this test"
QUIT
+2 ;
+3 NEW ARRAY,ERROR,INSERT,OK,SCORE,SUB,YT,X
+4 ;
+5 IF RESULT["~"
SET RESULT=$PIECE(RESULT,"~")
+6 SET ERROR=0
+7 ;
+8 ;Get score using API
+9 KILL ^TMP($JOB,"YSCOR")
+10 IF ORES("CODE")'="DOM80"
Begin DoDot:1
+11 MERGE YT=ORES
+12 FOR X=1:1:$LENGTH(YT("R1"))
IF $EXTRACT(YT("R1"),X)'="X"
SET YT(X)=X_U_$EXTRACT(YT("R1"),X)
+13 KILL YT("R1")
+14 DO CHECKCR^YTQPXRM4(.ARRAY,.YT)
+15 SET OK=0
+16 ;D PREVIEW^YTAPI4(.ARRAY,.YT)
+17 IF ^TMP($JOB,"YSCOR",1)'="[DATA]"
SET ORY(1)="-1^"_^TMP($JOB,"YSCOR",1)_^TMP($JOB,"YSCOD",2)
SET ERROR=1
QUIT
+18 ;I ARRAY(1)'="[DATA]" S ORY(1)="-1^"_ARRAY(1)_ARRAY(2),ERROR=1 Q
+19 IF $PIECE($GET(^TMP($JOB,"YSCOR",2)),"=",2)'=""
SET SCORE=$PIECE($GET(^TMP($JOB,"YSCOR",2)),"=",2)
SET OK=1
+20 ;S SUB=0,OK=0
+21 ;F S SUB=$O(ARRAY(SUB)) Q:'SUB D Q:OK
+22 ;.I $P(ARRAY(SUB),U)="S1" S SCORE=$P(ARRAY(SUB),U,3),OK=1
+23 IF 'OK
SET ORY(1)="-1^[ERROR] no score returned"
SET ERROR=1
QUIT
End DoDot:1
if ERROR
QUIT
+24 ;
+25 ;Except for DOM80
+26 IF ORES("CODE")="DOM80"
Begin DoDot:1
+27 IF $EXTRACT(ORES("R1"))="Y"
SET SCORE=1
QUIT
+28 IF $EXTRACT(ORES("R1"),2,3)="YY"
IF ($EXTRACT(ORES("R1"),4)>1)
SET SCORE=1
QUIT
+29 SET SCORE=0
End DoDot:1
+30 ;
+31 SET DFN=$GET(ORES("DFN"))
+32 SET INSERT("SCORE")=SCORE
+33 ;
+34 ;For AIMS special formatting is required
+35 IF ORES("CODE")="AIMS"
Begin DoDot:1
+36 NEW CNT,LITS,RESP,SUM
+37 SET LITS(0)="none"
SET LITS(1)="minimal"
SET LITS(2)="mild"
SET LITS(3)="moderate"
+38 SET LITS(4)="severe"
SET SUM(2)=0
SET SUM(3)=0
SET SUM(4)=0
+39 FOR CNT=1:1
SET RESP=$EXTRACT(ORES("R1"),CNT)
if RESP=""
QUIT
Begin DoDot:2
+40 SET INSERT("R"_CNT)=$GET(LITS(RESP))
+41 IF (CNT<8)
IF (234[RESP)
SET SUM(RESP)=SUM(RESP)+1
End DoDot:2
+42 FOR CNT=2,3,4
SET INSERT("SUM"_CNT)=SUM(CNT)
End DoDot:1
+43 ;
TEXT ;
+1 IF RESULT["~"
SET RESULT=$PIECE(RESULT,"~")
+2 ;Load dialog results into ORY array
+3 NEW DATA,DCON,DITEM,DSEQ,DSUB,DTYP,INS,SEP,TEXT
+4 ;Get the result elements
+5 SET DSEQ=0
SET OCNT=0
+6 FOR
SET DSEQ=$ORDER(^PXRMD(801.41,RESULT,10,"B",DSEQ))
if 'DSEQ
QUIT
Begin DoDot:1
+7 SET DSUB=$ORDER(^PXRMD(801.41,RESULT,10,"B",DSEQ,""))
if 'DSUB
QUIT
+8 SET DITEM=$PIECE($GET(^PXRMD(801.41,RESULT,10,DSUB,0)),U,2)
if 'DITEM
QUIT
+9 ;Get the result element
+10 SET DTYP=$PIECE($GET(^PXRMD(801.41,DITEM,0)),U,4)
if DTYP'="T"
QUIT
+11 ;Get the result element condition
+12 SET DCON=$PIECE($GET(^PXRMD(801.41,DITEM,0)),U,13)
+13 ;Skip if condition not satisfied
+14 IF DCON'=""
SET DCON=$TRANSLATE(DCON,"~"," ")
if '$$TRUE(SCORE,DCON,DFN)
QUIT
+15 ;Get progress note text if defined
+16 NEW LAST,NULL,SUB,TEXT
SET SUB=0
SET LAST=0
+17 FOR
SET SUB=$ORDER(^PXRMD(801.41,DITEM,35,SUB))
if 'SUB
QUIT
Begin DoDot:2
+18 ;Insert score into text (if neccessary)
+19 SET TEXT=$GET(^PXRMD(801.41,DITEM,35,SUB,0))
+20 SET NULL=0
IF ($EXTRACT(TEXT)=" ")!(TEXT="")
SET NULL=1
+21 ;Add line breaks if is or preceded by blank line or starts with space
+22 IF ('NULL)
IF LAST
SET TEXT="<br>"_TEXT
+23 SET TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
+24 SET LAST=0
IF NULL
SET TEXT="<br>"_TEXT
SET LAST=1
+25 ;Check for inserts - note there may be embedded TIU markers too
+26 NEW INS
+27 SET INS=""
+28 FOR
SET INS=$ORDER(INSERT(INS))
if INS=""
QUIT
Begin DoDot:3
+29 SET SEP="|"_INS_"|"
IF '$FIND(TEXT,SEP)
QUIT
+30 SET TEXT=$PIECE(TEXT,SEP)_$GET(INSERT(INS))_$PIECE(TEXT,SEP,2,99)
End DoDot:3
+31 SET OCNT=OCNT+1
SET ORY(OCNT)=7_U_TEXT
End DoDot:2
End DoDot:1
+32 QUIT
+33 ;
MHDLL(ORES,RESULT,SCORE,DFN) ;
+1 SET INSERT("SCORE")=SCORE
+2 DO TEXT
+3 QUIT
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 QUIT
+11 ;
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
