Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXRMDRSG

PXRMDRSG.m

Go to the documentation of this file.
  1. PXRMDRSG ;SLC/AGP - DIALOG RESULTS LOADER ;09/27/2018
  1. ;;2.0;CLINICAL REMINDERS;**6,45**;Feb 04, 2005;Build 566
  1. ;
  1. ;Build score related P/N text from score and result group
  1. ;
  1. MHDLL(ORY,RESULTS,SCORES,DFN,DIEN) ;
  1. N ARY,CNT,INSERT,NODE,RESULT,SCORE,SCALENUM
  1. N OCNT,IMULT,MULT
  1. S OCNT=0,IMULT=0,MULT=0
  1. S CNT=0 F S CNT=$O(SCORES(CNT)) Q:CNT'>0 D
  1. .S NODE=$G(SCORES(CNT)) Q:NODE=""
  1. .S ARY($P(NODE,"~"))=$P(NODE,"~",2)
  1. S CNT=0 F S CNT=$O(RESULTS(CNT)) Q:CNT'>0 D
  1. .S RESULT=$G(RESULTS(CNT)) Q:RESULT=""
  1. .I $P($G(^PXRMD(801.41,RESULT,50)),U,1)="" Q
  1. .S SCALENUM=$P($G(^PXRMD(801.41,RESULT,50)),U,2) Q:SCALENUM=""
  1. .S SCORE=$G(ARY(SCALENUM)) Q:SCORE=""
  1. .S INSERT("SCORE")=SCORE
  1. .D TEXT(.ORY,.OCNT,IMULT,.MULT,SCORE)
  1. Q
  1. ;
  1. OUT(DATA) ;Display element details
  1. N DITEM S DITEM=$P(DATA,U,2) Q:'DITEM
  1. W $P($G(^PXRMD(801.41,DITEM,0)),U)
  1. W !,$J("Element Condition: ",19)
  1. W $TR($P($G(^PXRMD(801.41,DITEM,0)),U,13),"~"," ")
  1. W !,$J("Element text:",17)
  1. ;Get progress note text if defined
  1. N SUB,TEXT S SUB=0
  1. F S SUB=$O(^PXRMD(801.41,DITEM,35,SUB)) Q:'SUB D
  1. .S TEXT=$G(^PXRMD(801.41,DITEM,35,SUB,0)) W !,?5,TEXT
  1. W !,$J("Informational text:",17)
  1. N SUB,TEXT S SUB=0
  1. F S SUB=$O(^PXRMD(801.41,DITEM,25,SUB)) Q:'SUB D
  1. .S TEXT=$G(^PXRMD(801.41,DITEM,25,SUB,0)) W !,?5,TEXT
  1. Q
  1. ;
  1. TEXT(ORY,OCNT,IMULT,MULT,SCORE) ;
  1. ;Load dialog results into ORY array
  1. N DATA,DCON,DITEM,DSEQ,DSUB,DTYP,INS,SEP,TEXT
  1. N INFOTEXT
  1. ;S SCORE=$G(INSERT("SCORE")) Q:SCORE=""
  1. ;Get the result elements
  1. S DSEQ=0
  1. F S DSEQ=$O(^PXRMD(801.41,RESULT,10,"B",DSEQ)) Q:'DSEQ D
  1. .S DSUB=$O(^PXRMD(801.41,RESULT,10,"B",DSEQ,"")) Q:'DSUB
  1. .S DITEM=$P($G(^PXRMD(801.41,RESULT,10,DSUB,0)),U,2) Q:'DITEM
  1. .;Get the result element
  1. .S DTYP=$P($G(^PXRMD(801.41,DITEM,0)),U,4) Q:DTYP'="T"
  1. .;Get the result element condition
  1. .S DCON=$P($G(^PXRMD(801.41,DITEM,0)),U,13)
  1. .;Skip if condition not satisfied
  1. .I DCON'="" S DCON=$TR(DCON,"~"," ") Q:'$$TRUE(SCORE,DCON,DFN)
  1. .;Get progress note/Info text if defined
  1. .N LAST,NULL,SUB,TEXT S SUB=0,LAST=0
  1. .S INFOTEXT=""
  1. .F S SUB=$O(^PXRMD(801.41,DITEM,25,SUB)) Q:'SUB D
  1. ..S TEXT=$G(^PXRMD(801.41,DITEM,25,SUB,0))
  1. ..I INFOTEXT="" S INFOTEXT="[INFOTEXT]"
  1. ..S NULL=0 I ($E(TEXT)=" ")!(TEXT="") S NULL=1
  1. ..;Add line breaks if is or preceded by blank line or starts with space
  1. ..I ('NULL),LAST S TEXT="<br>"_TEXT
  1. ..S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
  1. ..S LAST=0 I NULL S TEXT="<br>"_TEXT,LAST=1
  1. ..I MULT=1,SUB=1,$E(TEXT,1,4)'="<br>" S TEXT="<br>"_TEXT
  1. ..S TEXT=$$STRREP^PXRMUTIL(TEXT,"<br>",U)
  1. ..I SUB=1,IMULT=1 S TEXT=U_TEXT
  1. ..S OCNT=OCNT+1,ORY(OCNT)=INFOTEXT_TEXT
  1. ..I IMULT=0,OCNT>0 S IMULT=1
  1. ..;S INFOTEXT=INFOTEXT_TEXT
  1. .;
  1. .S LAST=0,NULL=0,SUB=0
  1. .F S SUB=$O(^PXRMD(801.41,DITEM,35,SUB)) Q:'SUB D
  1. ..;Insert score into text (if neccessary)
  1. ..S TEXT=$G(^PXRMD(801.41,DITEM,35,SUB,0))
  1. ..S NULL=0 I ($E(TEXT)=" ")!(TEXT="") S NULL=1
  1. ..;Add line breaks if is or preceded by blank line or starts with space
  1. ..I ('NULL),LAST S TEXT="<br>"_TEXT
  1. ..S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
  1. ..S LAST=0 I NULL S TEXT="<br>"_TEXT,LAST=1
  1. ..I MULT=1,SUB=1,$E(TEXT,1,4)'="<br>" S TEXT="<br>"_TEXT
  1. ..;Check for inserts - note there may be embedded TIU markers too
  1. ..N INS
  1. ..S INS=""
  1. ..F S INS=$O(INSERT(INS)) Q:INS="" D
  1. ...S SEP="|"_INS_"|" I '$F(TEXT,SEP) Q
  1. ...S TEXT=$P(TEXT,SEP)_$G(INSERT(INS))_$P(TEXT,SEP,2,99)
  1. ..S OCNT=OCNT+1,ORY(OCNT)=TEXT
  1. ..I MULT=0,OCNT>0 S MULT=1
  1. .;I $G(INFOTEXT)'="" S OCNT=OCNT+1,ORY(OCNT)=INFOTEXT
  1. .D CHECKLNK(DIEN,RESULT,DITEM,.ORY,.OCNT)
  1. Q
  1. ;
  1. TRUE(V,COND,DFN) ; Check if value meets element condition
  1. N RESULT,SEX
  1. I COND["SEX" D Q RESULT
  1. . S RESULT=0
  1. . S SEX=$P($G(^DPT(DFN,0)),U,2)
  1. . X COND I S RESULT=1
  1. X COND I Q 1
  1. Q 0
  1. ;
  1. CHECKLNK(DIEN,RG,RE,ORY,OCNT) ;
  1. N ACT,FUNC,LIEN,LINK,LTYPE,NODE,NUM,NVALUE,OVALUE,OK,RESULT,RGNUM,INPUTS
  1. S RGNUM=$O(^PXRMD(801.41,DIEN,51,"B",RG,"")) I RGNUM'>0 Q
  1. S NUM=$O(^PXRMD(801.41,DIEN,51,RGNUM,1,"B",RE,"")) I NUM'>0 Q
  1. S NODE=$G(^PXRMD(801.41,DIEN,51,RGNUM,1,NUM,0))
  1. ;S LIEN=$P(NODE,U,2),LTYPE=$P(NODE,U,3),FUNC=$G(^PXRMD(801.41,DIEN,51,RGNUM,1,NUM,1))
  1. S LINK=$P(NODE,U,2) I LINK'>0 Q
  1. D GETLINK^PXRMDLLB(LINK,.LIEN,.LTYPE,.FUNC,.ACT)
  1. Q:LIEN'>0 Q:LTYPE="" Q:ACT=""
  1. I FUNC'="" D Q
  1. .S NUM=0 F S NUM=$O(^PXRMD(801.48,LINK,2,NUM)) Q:NUM'>0 D
  1. ..S NODE=$G(^PXRMD(801.48,LINK,2,NUM,0)),SUB=$P(NODE,U),VAL=$P(NODE,U,2) Q:SUB="" Q:VAL=""
  1. ..S INPUTS(SUB)=VAL
  1. .S RESULT="",RTN=$P($G(^PXRMD(801.47,FUNC,0)),U,2,3) Q:$P(RTN,U)="" Q:$P(RTN,U,2)=""
  1. .S NVALUE="",OVALUE=""
  1. .S TEMP="S RET=$$"_RTN_"(.RESULT,DFN,NVALUE,OVALUE,.INPUTS)"
  1. .X TEMP
  1. .I RESULT'=1 Q
  1. .S OCNT=OCNT+1,ORY(OCNT)="[LINK]"_U_LIEN_U_LTYPE_U_ACT
  1. ;X FUNC
  1. S OCNT=OCNT+1,ORY(OCNT)="[LINK]"_U_LIEN_U_LTYPE_U_ACT
  1. Q
  1. ;