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