PXRMDLLB ;SLC/PJH - REMINDER DIALOG LOADER ;Jan 12, 2023@19:11
;;2.0;CLINICAL REMINDERS;**6,12,16,26,47,45,65,84**;Feb 04, 2005;Build 2
;
; Reference to RESULTS^WVALERTS in ICR #4102
CODES(TXIEN,DTYPE,CODESYS,ARRAY) ;
N CNT,CODE,DATES,END,IEN,NODE,START,TEXT,TYPE
S CNT=0
S TYPE="" F S TYPE=$O(CODESYS(TYPE)) Q:TYPE="" D
.S CODE="" F S CODE=$O(^PXD(811.2,TXIEN,20,"AUID",TYPE,CODE)) Q:CODE="" D
..S START="" F S START=$O(^PXD(811.2,TXIEN,20,"AUID",TYPE,CODE,START)) Q:START="" D
...S END="" F S END=$O(^PXD(811.2,TXIEN,20,"AUID",TYPE,CODE,START,END)) Q:END="" D
....S NODE=$G(^PXD(811.2,TXIEN,20,"AUID",TYPE,CODE,START,END)) I NODE="" Q
....S IEN=$S(DTYPE="SC":CODE,1:$P(NODE,U)),TEXT=$P(NODE,U,2)
....S DATES=START_":"_$S(END>0:END,1:"")
....S CNT=CNT+1,ARRAY(CNT)=IEN_U_$G(CODE)_":"_$G(DATES)_U_$G(TEXT)_U_U_TYPE
Q
;
EXPTAX(DITEM,TIEN,DCUR,NDATA) ;
;this function handles taxonomy that are set to not display.
N CAT,DTTYP,FIND,FILE,NODE,TSEL
S NODE=$G(^PXRMD(801.41,DITEM,"TAX"))
S TSEL=$P(NODE,U)
I "ND"[TSEL D
.D EXP(DITEM,TIEN,DCUR,"CPT",3,NDATA)
.D EXP(DITEM,TIEN,DCUR,"SC",3,NDATA)
I "NP"[TSEL D
.D EXP(DITEM,TIEN,DCUR,"POV",3,NDATA)
.D EXP(DITEM,TIEN,DCUR,"SC",3,NDATA)
I "NS"[TSEL D
.D EXP(DITEM,TIEN,DCUR,"CPT",3,NDATA)
.D EXP(DITEM,TIEN,DCUR,"POV",3,NDATA)
Q
;
EXP(DITEM,TIEN,DCUR,DTTYP,TYPE,NDATA) ;Expand taxonomy codes
N CAT,CODES,CODETYPE,CNT,DATANODE,ENC,FILE,LIT,OLDMAG
I DTTYP="" Q
S LIT="Selectable "_$S(DTTYP="POV":"Diagnoses:",DTTYP="SC":"Standard Codes:",1:"Procedures:")
S CAT=$P($G(^PXD(811.2,TIEN,0)),U)
;
S DATANODE=$G(^PXRMD(801.41,DITEM,"DATA"))
D BLDCODE^PXRMDTAX(DTTYP,.CODETYPE)
S OCNT=OCNT+1
I TYPE=5 D
.S ORY(OCNT)=3_U_DITEM_U_U_DTTYP_U_1_U_TIEN_U_U_U_CAT_U_LIT
.S $P(ORY(OCNT),U,16)=+NDATA
.S $P(ORY(OCNT),U,17)=$P(DATANODE,U)
;
;Get selectable codes
D CODES(TIEN,DTTYP,.CODETYPE,.CODES)
S CNT=0
;Save selectable codes as type 5 or 3 records
F S CNT=$O(CODES(CNT)) Q:'CNT D
.S OCNT=OCNT+1,ORY(OCNT)=TYPE_U_DITEM_U_U_DTTYP_U_U_CODES(CNT)
.S $P(ORY(OCNT),U,16)=+NDATA
.S $P(ORY(OCNT),U,17)=$P(DATANODE,U)
Q
;
GETLINK(LINK,ITEM,TYPE,FUNC,ACT) ;
N NODE,RESULT
S NODE=$G(^PXRMD(801.48,LINK,0)) Q:$P(NODE,U,5)=""
S ITEM=$P(NODE,U,2),TYPE=$P(NODE,U,3),FUNC=$P(NODE,U,4)
I TYPE="" S TYPE="ELEMENT"
I TYPE>0 S TYPE=$P($G(^PXRMD(801.42,TYPE,0)),U)
S ACT=$P(NODE,U,5)
S ACT=$S(ACT="C":"CHECKED",ACT="S":"SUPPRESS",ACT="R":"REQUIRED",ACT="V":$G(RESULT),ACT="UC":"UNCHECKED",ACT="US":"UNSUPPRESS",ACT="D":"DISABLE",ACT="E":"UNDISABLE",1:"")
S $P(ACT,U,2)=$S(+$O(^PXRMD(801.48,LINK,3,0))>0:LINK,1:0)
Q
GETLSEQ(RETURN,LINK) ;Return SEQUENCES AFFECTED BY LINK field value
S RETURN(0)=0
I '$D(^PXRMD(801.48,+$G(LINK),0)) Q
N SUB,NODE
S NODE=1
S SUB=0 F S SUB=$O(^PXRMD(801.48,LINK,3,SUB)) Q:SUB'>0 D
.S RETURN(NODE)=$P($G(^PXRMD(801.48,LINK,3,SUB,0)),U)_"~",NODE=NODE+1
.S RETURN(NODE)=$P($G(^PXRMD(801.48,LINK,3,SUB,1)),U),NODE=NODE+1
.S RETURN(NODE)=$P($G(^PXRMD(801.48,LINK,3,SUB,2)),U),NODE=NODE+1
S RETURN(0)=NODE-1
Q
;
MST(DFTYP,DFIEN) ;Pass MST code as a forced value
;Validate finding ien
Q:DFIEN=""
;For each MST term check if finding is mapped
N FOUND,TCOND,TIEN,TNAM,TSUB
S FOUND=0
F TNAM="POSITIVE","NEGATIVE","DECLINES" D Q:FOUND
.;Get term IEN
.S TIEN=$O(^PXRMD(811.5,"B","MST "_TNAM_" REPORT","")) Q:'TIEN
.;Check if finding is mapped to term
.Q:'$D(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN))
.;If exam and term condition logic is null ignore
.I DFTYP="AUTTEXAM(" D Q:TCOND=""
..S TCOND="",TSUB=$O(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN,"")) Q:'TSUB
..S TCOND=$P($G(^PXRMD(811.5,TIEN,20,TSUB,3)),U)
.;If it is then create additional prompt for MST
.N DSEQ,DEXC,DDEF,DGUI,DTYP,DTEXT,DSNL,DREQ
.;Add to end of array
.S DSEQ=$O(ARRAY(""),-1)+1
.;Null fields
.S DDEF="",DEXC="",DTEXT="",DSNL="",DREQ=""
.;MST status (exept for exams)
.I DFTYP'="AUTTEXAM(" S DDEF=$$STCODE^PXRMMST("MST "_TNAM_" REPORT")
.;GUI process and forced value
.S DGUI="MST",DTYP="F"
.;Save in array
.S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ
.;Quit after the first term is found
.S FOUND=1
Q
;
NREPLACE(DFN,DITEM,DATA,FAIL,BLTXT) ;
N ACTION,BLEVTXT,CDFIEVAL,FACTION,FIEVAL,FNODE,DITEMO,FOUND,IEN,ITEM,NODE,REPLACE,RESULT,SEQ,STATUS,TEMP
S FACTION="",FNODE="",REPLACE=0,BLEVTXT=0,RESULT=0
S FOUND=0,SEQ=0 F S SEQ=$O(^PXRMD(801.41,DITEM,"BL","B",SEQ)) Q:SEQ'>0!(FOUND=1)!(FAIL=1) D
.S RESULT=0
.S IEN=$O(^PXRMD(801.41,DITEM,"BL","B",SEQ,"")) Q:IEN'>0
.S NODE=$G(^PXRMD(801.41,DITEM,"BL",IEN,0))
.S ITEM=$P(NODE,U,2),STATUS=$P(NODE,U,3),ACTION=$P(NODE,U,4)
.I ITEM["811.9" D
..K CDFIEVAL,FIEVAL
..S TEMP=$$REMEVAL(+ITEM,DFN,$G(DITEM),STATUS,"D",.FIEVAL,.CDFIEVAL)
..I TEMP=-1 S FAIL=1 D SENDMSG^PXRMORCH(DFN,"dialog",$P($G(^PXRMD(801.41,DIALOGIEN,0)),U),"definition",+ITEM) Q
..S RESULT=$$STATMTCH^PXRMORCH(TEMP,STATUS)
..I $D(CDFIEVAL) K FIEVAL M FIEVAL=CDFIEVAL
.I ITEM["811.5" D
..S TEMP=$$TERM(+ITEM,DFN,$G(DITEM),"D",.FIEVAL)
..I TEMP=-1 S FAIL=1 D SENDMSG^PXRMORCH(DFN,"dialog",$P($G(^PXRMD(801.41,DIALOGIEN,0)),U),"term",+ITEM) Q
..I TEMP=0,STATUS="F" S RESULT=1
..I TEMP=1,STATUS="T" S RESULT=1
.I FAIL=1 Q
.I RESULT=1 S FOUND=1,FACTION=ACTION,FNODE=NODE,BLEVTXT=+$P(NODE,U,6)
.I RESULT=0,+$P(NODE,U,6)=2 S BLEVTXT=2
Q:FAIL=1
I FOUND=1 D
.I FACTION="H" K DITEM,DATA Q
.I FACTION="C" S $P(DATA,U,11)="C" Q
.I FACTION="S" S $P(DATA,U,11)=1,$P(DATA,U,10)=0 Q
.I FACTION="0"!(+FACTION>0) S $P(DATA,U,9)=FACTION Q
.S DITEM=$P(FNODE,U,5),DATA=$G(^PXRMD(801.41,DITEM,0)) S REPLACE=1
.I $G(DATA)=""!($$ISDISAB^PXRMDLL(DITEM)=1) S DITEM=$O(^PXRMD(801.41,"B","VA-DISABLE BRANCHING LOGIC REPLACEMENT ELEMENT","")),REPLACE=0
I $G(DITEM)>0,$P($G(^PXRMD(801.41,DITEM,0)),U,16)["CRGF" D FIEVAL(DITEM,.FIEVAL,BLEVTXT,.BLTXT)
I RESULT=1,REPLACE=1,$P($G(^PXRMD(801.41,DITEM,0)),U,16)["WHR" D WH(.FIEVAL)
I REPLACE=1,$D(^PXRMD(801.41,DITEM,"BL")) D NREPLACE(DFN,.DITEM,.DATA,.FAIL)
Q
;
FIEVAL(IEN,FIEVAL,BLEVTXT,BLTXT) ;
N CSUB,CSUBS,ERR,FIELD,FILE,FINDINGS,IDX,NODE,NUM,PKG,PKGNAME,PKGPFIX,SUB,TYPE,X,Y
S SUB=+$O(BLTXT("?"),-1)
;Need to find term marked for dialog.
S NUM=0 F S NUM=$O(FIEVAL(NUM)) Q:NUM'>0 D
.Q:'$D(FIEVAL(NUM,1))
.;make sure fieval is available for dialog use
.I +$G(FIEVAL(NUM,1,"DIALOG"))'=1 Q
.;set dialog text to build automatically
.I BLEVTXT>0 D ;Q:BLEVTXT=2
..I $G(FIEVAL(NUM,1,"TEXT"))'="" S SUB=SUB+1,BLTXT(SUB)=FIEVAL(NUM,1,"TEXT")
..I $D(FIEVAL(NUM,1,"TEXT"))>1 D
...S X=0 F S X=$O(FIEVAL(NUM,1,"TEXT",X)) Q:X'>0 S SUB=SUB+1,BLTXT(SUB)=FIEVAL(NUM,1,"TEXT",X)
.;check to see if finding match the package in term evaluation
.S PKGNAME=$G(FIEVAL(NUM,1,"PACKAGE")) Q:PKGNAME=""
.S PKGPFIX=$G(FIEVAL(NUM,1,"PACKAGE PREFIX")) Q:PKGPFIX=""
.S PKG=$$FIND1^DIC(9.4,"",,PKGNAME,,"I $P(^(0),U,2)="""_PKGPFIX_"""","ERR") I PKG'>0 Q
.I '$D(^PXRMD(801.46,"P",PKG)) Q
.;retrieve general findings from current dialog
.D:'$D(FINDINGS) FINDGFIN(IEN,PKG,.FINDINGS)
.;Find record ID for this FIEVAL
.N DAS
.S CSUB="" F S CSUB=$O(FINDINGS("PXRM CID INDEX",CSUB)) Q:CSUB=""!($G(DAS)'="") D
..I '$D(FIEVAL(NUM,1,CSUB)) Q
..S DAS=FIEVAL(NUM,1,CSUB),DAS("FILE")=$P(FINDINGS(CSUB),U)
.Q:$G(DAS)=""
.S CSUB="" F S CSUB=$O(FINDINGS(CSUB)) Q:CSUB="" D
..I '$D(FIEVAL(NUM,1,CSUB)) Q
..Q:$D(CSUBS(CSUB))
..S NODE=FINDINGS(CSUB)
..S FILE=$P(NODE,U),TYPE=$P(NODE,U,3),PKG=$P(NODE,U,5)
..I FILE<=0!(TYPE="")!(PKG="") Q
..S FIELD=$P(NODE,U,2) I FIELD="" Q
..I $G(^TMP($J,"PXRM GEN FINDING",DIALOGIEN,PKG,FILE))="",FILE=DAS("FILE") S ^TMP($J,"PXRM GEN FINDING",DIALOGIEN,PKG,FILE)=DAS
..I TYPE="S",$G(FIEVAL(NUM,1,CSUB))'="" S ^TMP($J,"PXRM GEN FINDING",DIALOGIEN,PKG,FILE,FIELD,DAS)=FIEVAL(NUM,1,CSUB)
..I TYPE="M" D
...S IDX=0 F S IDX=$O(FIEVAL(NUM,1,CSUB,IDX)) Q:'IDX D
....S ^TMP($J,"PXRM GEN FINDING",DIALOGIEN,PKG,FILE,FIELD,IDX_","_DAS)=$G(FIEVAL(NUM,1,CSUB,IDX))
..S CSUBS(CSUB)=""
Q
;
REMEVAL(RIEN,DFN,IEN,STATUS,TYPE,FIEVAL,CDFIEVAL) ;
N DEFARR,NODE,RNAME,PXRMDEFS,RSTAT
K ^TMP("PXRHM",$J)
I $D(^TMP($J,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN)) D Q RSTAT
.M FIEVAL=^TMP($J,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN,"FIEVAL")
.I $D(^TMP($J,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN,"CDFIEVAL")) K FIEVAL M FIEVAL=^TMP($J,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN,"CDFIEVAL")
.S RSTAT=^TMP($J,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN,"STATUS")
S NODE=$G(^PXD(811.9,RIEN,0))
S RNAME=$S($P(NODE,U,3)'="":$P(NODE,U,3),1:$P(NODE,U))
D DEF^PXRMLDR(RIEN,.DEFARR)
D EVAL^PXRM(DFN,.DEFARR,5,1,.FIEVAL,DT)
S RSTAT=$P($G(^TMP("PXRHM",$J,RIEN,RNAME)),U)
K ^TMP("PXRHM",$J)
I RSTAT="ERROR" Q -1
M ^TMP($J,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN,"FIEVAL")=FIEVAL
S ^TMP($J,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN,"STATUS")=RSTAT
I $P($G(^PXRMD(801.41,IEN,0)),U,16)'["CRGF" Q RSTAT
I $D(^TMP($J,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN,"CDFIEVAL")) M CDFIEVAL=^TMP($J,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN,"CDFIEVAL") Q
M CDFIEVAL=^TMP("PXRM BL DATA",$J,"FIEVAL") K ^TMP("PXRM BL DATA",$J)
M ^TMP($J,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN,"CDFIEVAL")=CDFIEVAL
Q RSTAT
;
RESGROUP(DIEN) ;
N CNT,RESULT,TEMP
S RESULT=""
I $$PATCH^XPDUTL("OR*3.0*243")=0 D Q RESULT
.S RESULT=$P($G(^PXRMD(801.41,DIEN,51,1,0)),U) I RESULT="" Q
.I $$ISDISAB^PXRMDLL(RESULT)=1 S RESULT="" Q
S CNT=0 F S CNT=$O(^PXRMD(801.41,DIEN,51,CNT)) Q:CNT'>0 D
.S TEMP=$P($G(^PXRMD(801.41,DIEN,51,CNT,0)),U) I TEMP="" Q
.I $$ISDISAB^PXRMDLL(TEMP)=1 S TEMP="" Q
.S RESULT=$S(RESULT="":TEMP,1:RESULT_"~"_TEMP)
Q RESULT
;
TERM(TERMIEN,DFN,IEN,TYPE,FIEVAL) ;
;this section is use to for the term evaluation
N CDFIEVAL,RESULT,TFAIL
S TFAIL=0
D TERMEVAL(DFN,IEN,$G(DIALOGIEN),TERMIEN,.FIEVAL,.CDFIEVAL,.TFAIL)
I TFAIL=1 Q -1
S RESULT=$G(FIEVAL(1))
I $D(CDFIEVAL)>0 K FIEVAL M FIEVAL=CDFIEVAL
Q RESULT
;
TERMEVAL(DFN,IEN,DIALOGIEN,TERMIEN,FIEVAL,CDFIEVAL,TFAIL) ;
N CLEAN,FINDPA,PXRMITEM,PXRMPID,TERMARR
S TERMARR="",PXRMITEM=TERMIEN,PXRMPID="PXRMTERM"_PXRMITEM_$H,CLEAN=0
K FIEVAL,CDFIEVAL
;order checks only
I +DIALOGIEN=0 D Q
.D TERM^PXRMLDR(TERMIEN,.TERMARR)
.;term evaulation
.S FINDPA(0)=""
.D IEVALTER^PXRMTERM(DFN,.FINDPA,.TERMARR,1,.FIEVAL)
.I $D(^TMP(PXRMPID,$J,TERMIEN)) S TFAIL=1
;dialog branching logic process
;if Cache exist used results
I $D(^TMP($J,"PXRM DIALOG EVAL",DIALOGIEN,"TERM",TERMIEN)) D Q
.M FIEVAL=^TMP($J,"PXRM DIALOG EVAL",DIALOGIEN,"TERM",TERMIEN,"FIEVAL")
.M CDFIEVAL=^TMP($J,"PXRM DIALOG EVAL",DIALOGIEN,"TERM",TERMIEN,"CDFIEVAL")
;build term array
D TERM^PXRMLDR(TERMIEN,.TERMARR)
I '$D(PXRMSRCFF) S PXRMSRCFF=1,CLEAN=1
;term evaluation
S FINDPA(0)=""
D IEVALTER^PXRMTERM(DFN,.FINDPA,.TERMARR,1,.FIEVAL)
I $D(^TMP(PXRMPID,$J,TERMIEN)) S TFAIL=1 Q
M ^TMP($J,"PXRM DIALOG EVAL",DIALOGIEN,"TERM",TERMIEN,"FIEVAL")=FIEVAL
I $P($G(^PXRMD(801.41,IEN,0)),U,16)'["CRGF" Q
I $D(^TMP($J,"PXRM DIALOG EVAL",DIALOGIEN,"TERM",TERMIEN,"CDFIEVAL")) M CDFIEVAL=^TMP($J,"PXRM DIALOG EVAL",DIALOGIEN,"TERM",TERMIEN,"CDFIEVAL") Q
M CDFIEVAL=^TMP("PXRM BL DATA",$J,"FIEVAL") I CLEAN K ^TMP("PXRM BL DATA",$J),PXRMSRCFF
M ^TMP($J,"PXRM DIALOG EVAL",DIALOGIEN,"TERM",TERMIEN,"CDFIEVAL")=CDFIEVAL
Q
;
FINDGFIN(IEN,PKG,FINDINGS) ; Return list of GENERAL FINDINGS in dialog
I IEN'>0 Q
N CIEN,FINDING,AFIEN
S CIEN=0 F S CIEN=$O(^PXRMD(801.41,IEN,10,CIEN)) Q:'+CIEN D
.I $P(^PXRMD(801.41,IEN,10,CIEN,0),U,2)'="" D FINDGFIN($P(^PXRMD(801.41,IEN,10,CIEN,0),U,2),PKG,.FINDINGS)
S FINDING=$P($G(^PXRMD(801.41,IEN,1)),U,5)
I FINDING[";PXRMD(801.46,",$D(^PXRMD(801.46,+FINDING))>9 D
.D FINDDATA(+FINDING,PKG,.FINDINGS)
S AFIEN=0 F S AFIEN=$O(^PXRMD(801.41,IEN,3,AFIEN)) Q:'+AFIEN D
.S FINDING=$P($G(^PXRMD(801.41,IEN,3,AFIEN,0)),U)
.I FINDING[";PXRMD(801.46,",$D(^PXRMD(801.46,+FINDING))>9 D
..D FINDDATA(+FINDING,PKG,.FINDINGS)
Q
;
FINDDATA(FIND,PKG,FINDINGS) ;
N FILE,FIELD,NDATA,NODE,CID,SUB,TYPE,X
S FILE=$P($G(^PXRMD(801.46,FIND,0)),U,3) I FILE="" Q
I $P($G(^PXRMD(801.46,FIND,0)),U,2)'=PKG Q
S NODE=$G(^PXRMD(801.46,FIND,3))
S NDATA=$P(NODE,U,2) I NDATA=1 Q
S CID=$P(NODE,U,3),TYPE=$P(NODE,U)
F X=1,2 D
.S NODE=$G(^PXRMD(801.46,FIND,X))
.S SUB=$P(NODE,U,3) Q:SUB=""
.S FINDINGS(SUB)=FILE_U_$P(NODE,U,2)_U_TYPE_U_CID_U_PKG
.I CID S FINDINGS("PXRM CID INDEX",$P(NODE,U,3))=""
Q
;
WH(FIEVAL) ;
N ARRAY,DATE,ESUB,IDENT,DATE,NODE,STR,WVIEN
S IDENT=$P($G(^PXRMD(801.41,DITEM,0)),U,16)
I $G(FIEVAL(1,"LINK"))=1,$G(FIEVAL(1,"STATUS"))="OPEN",$G(FIEVAL(1,"VALUE"))="Pending" D
.S WVIEN=$G(FIEVAL(1,"WVIEN"))
.D RESULTS^WVALERTS(.ARRAY,WVIEN) D
..K WHFIND,WHNAME
..S NODE=$G(ARRAY(0)) I +$P(NODE,U)'>0 Q
..S WHFIND=WVIEN_";WV(790.1,",WHNAME=$P($G(NODE),U,3)
..S (ESUB,SUB)=0 F S SUB=$O(DTXT(SUB)) Q:SUB'>0 S ESUB=SUB
..S ESUB=ESUB+1
..I IDENT="WHRP" D
...N MOD
...S DATE=""
...S DTXT(ESUB)=$P($G(NODE),U,3),ESUB=ESUB+1
...S DATE=$P($G(NODE),U,4),STR=$$RJ^XLFSTR("Collected: ",20)
...S STR=STR_$P($G(NODE),U,8)
...S DTXT(ESUB)=STR,ESUB=ESUB+1
...S STR=$$RJ^XLFSTR("Lab Accession #: ",20),STR=STR_$P($G(NODE),U,9)
...S DTXT(ESUB)=STR,ESUB=ESUB+1
...S STR=$$RJ^XLFSTR("Specimen: ",20),STR=STR_$P($G(NODE),U,10)
...S DTXT(ESUB)=STR
..I IDENT="WHRM" D
...S STR=$$RJ^XLFSTR("Procedure: ",20),STR=STR_$P($G(NODE),U,5)
...S DTXT(ESUB)=STR,ESUB=ESUB+1
...S STR=$$RJ^XLFSTR("Primary Diagnosis: ",20),STR=STR_$P($G(NODE),U,6)
...S DTXT(ESUB)=STR,ESUB=ESUB+1
...S STR=$$RJ^XLFSTR("Modifiers: ",20),MOD=$P($G(NODE),U,7)
...I $G(MOD)="" S STR=STR_"<none>"
...E S STR=STR_$P($G(MOD),"~",1)
...S DTXT(ESUB)=STR,ESUB=ESUB+1
...I $P($G(MOD),"~",2)'="" S DTXT(ESUB)=$$LJ^XLFSTR($P(MOD,"~",2),23)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMDLLB 13939 printed Sep 23, 2025@19:20:03 Page 2
PXRMDLLB ;SLC/PJH - REMINDER DIALOG LOADER ;Jan 12, 2023@19:11
+1 ;;2.0;CLINICAL REMINDERS;**6,12,16,26,47,45,65,84**;Feb 04, 2005;Build 2
+2 ;
+3 ; Reference to RESULTS^WVALERTS in ICR #4102
CODES(TXIEN,DTYPE,CODESYS,ARRAY) ;
+1 NEW CNT,CODE,DATES,END,IEN,NODE,START,TEXT,TYPE
+2 SET CNT=0
+3 SET TYPE=""
FOR
SET TYPE=$ORDER(CODESYS(TYPE))
if TYPE=""
QUIT
Begin DoDot:1
+4 SET CODE=""
FOR
SET CODE=$ORDER(^PXD(811.2,TXIEN,20,"AUID",TYPE,CODE))
if CODE=""
QUIT
Begin DoDot:2
+5 SET START=""
FOR
SET START=$ORDER(^PXD(811.2,TXIEN,20,"AUID",TYPE,CODE,START))
if START=""
QUIT
Begin DoDot:3
+6 SET END=""
FOR
SET END=$ORDER(^PXD(811.2,TXIEN,20,"AUID",TYPE,CODE,START,END))
if END=""
QUIT
Begin DoDot:4
+7 SET NODE=$GET(^PXD(811.2,TXIEN,20,"AUID",TYPE,CODE,START,END))
IF NODE=""
QUIT
+8 SET IEN=$SELECT(DTYPE="SC":CODE,1:$PIECE(NODE,U))
SET TEXT=$PIECE(NODE,U,2)
+9 SET DATES=START_":"_$SELECT(END>0:END,1:"")
+10 SET CNT=CNT+1
SET ARRAY(CNT)=IEN_U_$GET(CODE)_":"_$GET(DATES)_U_$GET(TEXT)_U_U_TYPE
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
EXPTAX(DITEM,TIEN,DCUR,NDATA) ;
+1 ;this function handles taxonomy that are set to not display.
+2 NEW CAT,DTTYP,FIND,FILE,NODE,TSEL
+3 SET NODE=$GET(^PXRMD(801.41,DITEM,"TAX"))
+4 SET TSEL=$PIECE(NODE,U)
+5 IF "ND"[TSEL
Begin DoDot:1
+6 DO EXP(DITEM,TIEN,DCUR,"CPT",3,NDATA)
+7 DO EXP(DITEM,TIEN,DCUR,"SC",3,NDATA)
End DoDot:1
+8 IF "NP"[TSEL
Begin DoDot:1
+9 DO EXP(DITEM,TIEN,DCUR,"POV",3,NDATA)
+10 DO EXP(DITEM,TIEN,DCUR,"SC",3,NDATA)
End DoDot:1
+11 IF "NS"[TSEL
Begin DoDot:1
+12 DO EXP(DITEM,TIEN,DCUR,"CPT",3,NDATA)
+13 DO EXP(DITEM,TIEN,DCUR,"POV",3,NDATA)
End DoDot:1
+14 QUIT
+15 ;
EXP(DITEM,TIEN,DCUR,DTTYP,TYPE,NDATA) ;Expand taxonomy codes
+1 NEW CAT,CODES,CODETYPE,CNT,DATANODE,ENC,FILE,LIT,OLDMAG
+2 IF DTTYP=""
QUIT
+3 SET LIT="Selectable "_$SELECT(DTTYP="POV":"Diagnoses:",DTTYP="SC":"Standard Codes:",1:"Procedures:")
+4 SET CAT=$PIECE($GET(^PXD(811.2,TIEN,0)),U)
+5 ;
+6 SET DATANODE=$GET(^PXRMD(801.41,DITEM,"DATA"))
+7 DO BLDCODE^PXRMDTAX(DTTYP,.CODETYPE)
+8 SET OCNT=OCNT+1
+9 IF TYPE=5
Begin DoDot:1
+10 SET ORY(OCNT)=3_U_DITEM_U_U_DTTYP_U_1_U_TIEN_U_U_U_CAT_U_LIT
+11 SET $PIECE(ORY(OCNT),U,16)=+NDATA
+12 SET $PIECE(ORY(OCNT),U,17)=$PIECE(DATANODE,U)
End DoDot:1
+13 ;
+14 ;Get selectable codes
+15 DO CODES(TIEN,DTTYP,.CODETYPE,.CODES)
+16 SET CNT=0
+17 ;Save selectable codes as type 5 or 3 records
+18 FOR
SET CNT=$ORDER(CODES(CNT))
if 'CNT
QUIT
Begin DoDot:1
+19 SET OCNT=OCNT+1
SET ORY(OCNT)=TYPE_U_DITEM_U_U_DTTYP_U_U_CODES(CNT)
+20 SET $PIECE(ORY(OCNT),U,16)=+NDATA
+21 SET $PIECE(ORY(OCNT),U,17)=$PIECE(DATANODE,U)
End DoDot:1
+22 QUIT
+23 ;
GETLINK(LINK,ITEM,TYPE,FUNC,ACT) ;
+1 NEW NODE,RESULT
+2 SET NODE=$GET(^PXRMD(801.48,LINK,0))
if $PIECE(NODE,U,5)=""
QUIT
+3 SET ITEM=$PIECE(NODE,U,2)
SET TYPE=$PIECE(NODE,U,3)
SET FUNC=$PIECE(NODE,U,4)
+4 IF TYPE=""
SET TYPE="ELEMENT"
+5 IF TYPE>0
SET TYPE=$PIECE($GET(^PXRMD(801.42,TYPE,0)),U)
+6 SET ACT=$PIECE(NODE,U,5)
+7 SET ACT=$SELECT(ACT="C":"CHECKED",ACT="S":"SUPPRESS",ACT="R":"REQUIRED",ACT="V":$GET(RESULT),ACT="UC":"UNCHECKED",ACT="US":"UNSUPPRESS",ACT="D":"DISABLE",ACT="E":"UNDISABLE",1:"")
+8 SET $PIECE(ACT,U,2)=$SELECT(+$ORDER(^PXRMD(801.48,LINK,3,0))>0:LINK,1:0)
+9 QUIT
GETLSEQ(RETURN,LINK) ;Return SEQUENCES AFFECTED BY LINK field value
+1 SET RETURN(0)=0
+2 IF '$DATA(^PXRMD(801.48,+$GET(LINK),0))
QUIT
+3 NEW SUB,NODE
+4 SET NODE=1
+5 SET SUB=0
FOR
SET SUB=$ORDER(^PXRMD(801.48,LINK,3,SUB))
if SUB'>0
QUIT
Begin DoDot:1
+6 SET RETURN(NODE)=$PIECE($GET(^PXRMD(801.48,LINK,3,SUB,0)),U)_"~"
SET NODE=NODE+1
+7 SET RETURN(NODE)=$PIECE($GET(^PXRMD(801.48,LINK,3,SUB,1)),U)
SET NODE=NODE+1
+8 SET RETURN(NODE)=$PIECE($GET(^PXRMD(801.48,LINK,3,SUB,2)),U)
SET NODE=NODE+1
End DoDot:1
+9 SET RETURN(0)=NODE-1
+10 QUIT
+11 ;
MST(DFTYP,DFIEN) ;Pass MST code as a forced value
+1 ;Validate finding ien
+2 if DFIEN=""
QUIT
+3 ;For each MST term check if finding is mapped
+4 NEW FOUND,TCOND,TIEN,TNAM,TSUB
+5 SET FOUND=0
+6 FOR TNAM="POSITIVE","NEGATIVE","DECLINES"
Begin DoDot:1
+7 ;Get term IEN
+8 SET TIEN=$ORDER(^PXRMD(811.5,"B","MST "_TNAM_" REPORT",""))
if 'TIEN
QUIT
+9 ;Check if finding is mapped to term
+10 if '$DATA(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN))
QUIT
+11 ;If exam and term condition logic is null ignore
+12 IF DFTYP="AUTTEXAM("
Begin DoDot:2
+13 SET TCOND=""
SET TSUB=$ORDER(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN,""))
if 'TSUB
QUIT
+14 SET TCOND=$PIECE($GET(^PXRMD(811.5,TIEN,20,TSUB,3)),U)
End DoDot:2
if TCOND=""
QUIT
+15 ;If it is then create additional prompt for MST
+16 NEW DSEQ,DEXC,DDEF,DGUI,DTYP,DTEXT,DSNL,DREQ
+17 ;Add to end of array
+18 SET DSEQ=$ORDER(ARRAY(""),-1)+1
+19 ;Null fields
+20 SET DDEF=""
SET DEXC=""
SET DTEXT=""
SET DSNL=""
SET DREQ=""
+21 ;MST status (exept for exams)
+22 IF DFTYP'="AUTTEXAM("
SET DDEF=$$STCODE^PXRMMST("MST "_TNAM_" REPORT")
+23 ;GUI process and forced value
+24 SET DGUI="MST"
SET DTYP="F"
+25 ;Save in array
+26 SET ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ
+27 ;Quit after the first term is found
+28 SET FOUND=1
End DoDot:1
if FOUND
QUIT
+29 QUIT
+30 ;
NREPLACE(DFN,DITEM,DATA,FAIL,BLTXT) ;
+1 NEW ACTION,BLEVTXT,CDFIEVAL,FACTION,FIEVAL,FNODE,DITEMO,FOUND,IEN,ITEM,NODE,REPLACE,RESULT,SEQ,STATUS,TEMP
+2 SET FACTION=""
SET FNODE=""
SET REPLACE=0
SET BLEVTXT=0
SET RESULT=0
+3 SET FOUND=0
SET SEQ=0
FOR
SET SEQ=$ORDER(^PXRMD(801.41,DITEM,"BL","B",SEQ))
if SEQ'>0!(FOUND=1)!(FAIL=1)
QUIT
Begin DoDot:1
+4 SET RESULT=0
+5 SET IEN=$ORDER(^PXRMD(801.41,DITEM,"BL","B",SEQ,""))
if IEN'>0
QUIT
+6 SET NODE=$GET(^PXRMD(801.41,DITEM,"BL",IEN,0))
+7 SET ITEM=$PIECE(NODE,U,2)
SET STATUS=$PIECE(NODE,U,3)
SET ACTION=$PIECE(NODE,U,4)
+8 IF ITEM["811.9"
Begin DoDot:2
+9 KILL CDFIEVAL,FIEVAL
+10 SET TEMP=$$REMEVAL(+ITEM,DFN,$GET(DITEM),STATUS,"D",.FIEVAL,.CDFIEVAL)
+11 IF TEMP=-1
SET FAIL=1
DO SENDMSG^PXRMORCH(DFN,"dialog",$PIECE($GET(^PXRMD(801.41,DIALOGIEN,0)),U),"definition",+ITEM)
QUIT
+12 SET RESULT=$$STATMTCH^PXRMORCH(TEMP,STATUS)
+13 IF $DATA(CDFIEVAL)
KILL FIEVAL
MERGE FIEVAL=CDFIEVAL
End DoDot:2
+14 IF ITEM["811.5"
Begin DoDot:2
+15 SET TEMP=$$TERM(+ITEM,DFN,$GET(DITEM),"D",.FIEVAL)
+16 IF TEMP=-1
SET FAIL=1
DO SENDMSG^PXRMORCH(DFN,"dialog",$PIECE($GET(^PXRMD(801.41,DIALOGIEN,0)),U),"term",+ITEM)
QUIT
+17 IF TEMP=0
IF STATUS="F"
SET RESULT=1
+18 IF TEMP=1
IF STATUS="T"
SET RESULT=1
End DoDot:2
+19 IF FAIL=1
QUIT
+20 IF RESULT=1
SET FOUND=1
SET FACTION=ACTION
SET FNODE=NODE
SET BLEVTXT=+$PIECE(NODE,U,6)
+21 IF RESULT=0
IF +$PIECE(NODE,U,6)=2
SET BLEVTXT=2
End DoDot:1
+22 if FAIL=1
QUIT
+23 IF FOUND=1
Begin DoDot:1
+24 IF FACTION="H"
KILL DITEM,DATA
QUIT
+25 IF FACTION="C"
SET $PIECE(DATA,U,11)="C"
QUIT
+26 IF FACTION="S"
SET $PIECE(DATA,U,11)=1
SET $PIECE(DATA,U,10)=0
QUIT
+27 IF FACTION="0"!(+FACTION>0)
SET $PIECE(DATA,U,9)=FACTION
QUIT
+28 SET DITEM=$PIECE(FNODE,U,5)
SET DATA=$GET(^PXRMD(801.41,DITEM,0))
SET REPLACE=1
+29 IF $GET(DATA)=""!($$ISDISAB^PXRMDLL(DITEM)=1)
SET DITEM=$ORDER(^PXRMD(801.41,"B","VA-DISABLE BRANCHING LOGIC REPLACEMENT ELEMENT",""))
SET REPLACE=0
End DoDot:1
+30 IF $GET(DITEM)>0
IF $PIECE($GET(^PXRMD(801.41,DITEM,0)),U,16)["CRGF"
DO FIEVAL(DITEM,.FIEVAL,BLEVTXT,.BLTXT)
+31 IF RESULT=1
IF REPLACE=1
IF $PIECE($GET(^PXRMD(801.41,DITEM,0)),U,16)["WHR"
DO WH(.FIEVAL)
+32 IF REPLACE=1
IF $DATA(^PXRMD(801.41,DITEM,"BL"))
DO NREPLACE(DFN,.DITEM,.DATA,.FAIL)
+33 QUIT
+34 ;
FIEVAL(IEN,FIEVAL,BLEVTXT,BLTXT) ;
+1 NEW CSUB,CSUBS,ERR,FIELD,FILE,FINDINGS,IDX,NODE,NUM,PKG,PKGNAME,PKGPFIX,SUB,TYPE,X,Y
+2 SET SUB=+$ORDER(BLTXT("?"),-1)
+3 ;Need to find term marked for dialog.
+4 SET NUM=0
FOR
SET NUM=$ORDER(FIEVAL(NUM))
if NUM'>0
QUIT
Begin DoDot:1
+5 if '$DATA(FIEVAL(NUM,1))
QUIT
+6 ;make sure fieval is available for dialog use
+7 IF +$GET(FIEVAL(NUM,1,"DIALOG"))'=1
QUIT
+8 ;set dialog text to build automatically
+9 ;Q:BLEVTXT=2
IF BLEVTXT>0
Begin DoDot:2
+10 IF $GET(FIEVAL(NUM,1,"TEXT"))'=""
SET SUB=SUB+1
SET BLTXT(SUB)=FIEVAL(NUM,1,"TEXT")
+11 IF $DATA(FIEVAL(NUM,1,"TEXT"))>1
Begin DoDot:3
+12 SET X=0
FOR
SET X=$ORDER(FIEVAL(NUM,1,"TEXT",X))
if X'>0
QUIT
SET SUB=SUB+1
SET BLTXT(SUB)=FIEVAL(NUM,1,"TEXT",X)
End DoDot:3
End DoDot:2
+13 ;check to see if finding match the package in term evaluation
+14 SET PKGNAME=$GET(FIEVAL(NUM,1,"PACKAGE"))
if PKGNAME=""
QUIT
+15 SET PKGPFIX=$GET(FIEVAL(NUM,1,"PACKAGE PREFIX"))
if PKGPFIX=""
QUIT
+16 SET PKG=$$FIND1^DIC(9.4,"",,PKGNAME,,"I $P(^(0),U,2)="""_PKGPFIX_"""","ERR")
IF PKG'>0
QUIT
+17 IF '$DATA(^PXRMD(801.46,"P",PKG))
QUIT
+18 ;retrieve general findings from current dialog
+19 if '$DATA(FINDINGS)
DO FINDGFIN(IEN,PKG,.FINDINGS)
+20 ;Find record ID for this FIEVAL
+21 NEW DAS
+22 SET CSUB=""
FOR
SET CSUB=$ORDER(FINDINGS("PXRM CID INDEX",CSUB))
if CSUB=""!($GET(DAS)'="")
QUIT
Begin DoDot:2
+23 IF '$DATA(FIEVAL(NUM,1,CSUB))
QUIT
+24 SET DAS=FIEVAL(NUM,1,CSUB)
SET DAS("FILE")=$PIECE(FINDINGS(CSUB),U)
End DoDot:2
+25 if $GET(DAS)=""
QUIT
+26 SET CSUB=""
FOR
SET CSUB=$ORDER(FINDINGS(CSUB))
if CSUB=""
QUIT
Begin DoDot:2
+27 IF '$DATA(FIEVAL(NUM,1,CSUB))
QUIT
+28 if $DATA(CSUBS(CSUB))
QUIT
+29 SET NODE=FINDINGS(CSUB)
+30 SET FILE=$PIECE(NODE,U)
SET TYPE=$PIECE(NODE,U,3)
SET PKG=$PIECE(NODE,U,5)
+31 IF FILE<=0!(TYPE="")!(PKG="")
QUIT
+32 SET FIELD=$PIECE(NODE,U,2)
IF FIELD=""
QUIT
+33 IF $GET(^TMP($JOB,"PXRM GEN FINDING",DIALOGIEN,PKG,FILE))=""
IF FILE=DAS("FILE")
SET ^TMP($JOB,"PXRM GEN FINDING",DIALOGIEN,PKG,FILE)=DAS
+34 IF TYPE="S"
IF $GET(FIEVAL(NUM,1,CSUB))'=""
SET ^TMP($JOB,"PXRM GEN FINDING",DIALOGIEN,PKG,FILE,FIELD,DAS)=FIEVAL(NUM,1,CSUB)
+35 IF TYPE="M"
Begin DoDot:3
+36 SET IDX=0
FOR
SET IDX=$ORDER(FIEVAL(NUM,1,CSUB,IDX))
if 'IDX
QUIT
Begin DoDot:4
+37 SET ^TMP($JOB,"PXRM GEN FINDING",DIALOGIEN,PKG,FILE,FIELD,IDX_","_DAS)=$GET(FIEVAL(NUM,1,CSUB,IDX))
End DoDot:4
End DoDot:3
+38 SET CSUBS(CSUB)=""
End DoDot:2
End DoDot:1
+39 QUIT
+40 ;
REMEVAL(RIEN,DFN,IEN,STATUS,TYPE,FIEVAL,CDFIEVAL) ;
+1 NEW DEFARR,NODE,RNAME,PXRMDEFS,RSTAT
+2 KILL ^TMP("PXRHM",$JOB)
+3 IF $DATA(^TMP($JOB,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN))
Begin DoDot:1
+4 MERGE FIEVAL=^TMP($JOB,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN,"FIEVAL")
+5 IF $DATA(^TMP($JOB,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN,"CDFIEVAL"))
KILL FIEVAL
MERGE FIEVAL=^TMP($JOB,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN,"CDFIEVAL")
+6 SET RSTAT=^TMP($JOB,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN,"STATUS")
End DoDot:1
QUIT RSTAT
+7 SET NODE=$GET(^PXD(811.9,RIEN,0))
+8 SET RNAME=$SELECT($PIECE(NODE,U,3)'="":$PIECE(NODE,U,3),1:$PIECE(NODE,U))
+9 DO DEF^PXRMLDR(RIEN,.DEFARR)
+10 DO EVAL^PXRM(DFN,.DEFARR,5,1,.FIEVAL,DT)
+11 SET RSTAT=$PIECE($GET(^TMP("PXRHM",$JOB,RIEN,RNAME)),U)
+12 KILL ^TMP("PXRHM",$JOB)
+13 IF RSTAT="ERROR"
QUIT -1
+14 MERGE ^TMP($JOB,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN,"FIEVAL")=FIEVAL
+15 SET ^TMP($JOB,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN,"STATUS")=RSTAT
+16 IF $PIECE($GET(^PXRMD(801.41,IEN,0)),U,16)'["CRGF"
QUIT RSTAT
+17 IF $DATA(^TMP($JOB,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN,"CDFIEVAL"))
MERGE CDFIEVAL=^TMP($JOB,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN,"CDFIEVAL")
QUIT
+18 MERGE CDFIEVAL=^TMP("PXRM BL DATA",$JOB,"FIEVAL")
KILL ^TMP("PXRM BL DATA",$JOB)
+19 MERGE ^TMP($JOB,"PXRM DIALOG EVAL",DIALOGIEN,"REMINDER",RIEN,"CDFIEVAL")=CDFIEVAL
+20 QUIT RSTAT
+21 ;
RESGROUP(DIEN) ;
+1 NEW CNT,RESULT,TEMP
+2 SET RESULT=""
+3 IF $$PATCH^XPDUTL("OR*3.0*243")=0
Begin DoDot:1
+4 SET RESULT=$PIECE($GET(^PXRMD(801.41,DIEN,51,1,0)),U)
IF RESULT=""
QUIT
+5 IF $$ISDISAB^PXRMDLL(RESULT)=1
SET RESULT=""
QUIT
End DoDot:1
QUIT RESULT
+6 SET CNT=0
FOR
SET CNT=$ORDER(^PXRMD(801.41,DIEN,51,CNT))
if CNT'>0
QUIT
Begin DoDot:1
+7 SET TEMP=$PIECE($GET(^PXRMD(801.41,DIEN,51,CNT,0)),U)
IF TEMP=""
QUIT
+8 IF $$ISDISAB^PXRMDLL(TEMP)=1
SET TEMP=""
QUIT
+9 SET RESULT=$SELECT(RESULT="":TEMP,1:RESULT_"~"_TEMP)
End DoDot:1
+10 QUIT RESULT
+11 ;
TERM(TERMIEN,DFN,IEN,TYPE,FIEVAL) ;
+1 ;this section is use to for the term evaluation
+2 NEW CDFIEVAL,RESULT,TFAIL
+3 SET TFAIL=0
+4 DO TERMEVAL(DFN,IEN,$GET(DIALOGIEN),TERMIEN,.FIEVAL,.CDFIEVAL,.TFAIL)
+5 IF TFAIL=1
QUIT -1
+6 SET RESULT=$GET(FIEVAL(1))
+7 IF $DATA(CDFIEVAL)>0
KILL FIEVAL
MERGE FIEVAL=CDFIEVAL
+8 QUIT RESULT
+9 ;
TERMEVAL(DFN,IEN,DIALOGIEN,TERMIEN,FIEVAL,CDFIEVAL,TFAIL) ;
+1 NEW CLEAN,FINDPA,PXRMITEM,PXRMPID,TERMARR
+2 SET TERMARR=""
SET PXRMITEM=TERMIEN
SET PXRMPID="PXRMTERM"_PXRMITEM_$HOROLOG
SET CLEAN=0
+3 KILL FIEVAL,CDFIEVAL
+4 ;order checks only
+5 IF +DIALOGIEN=0
Begin DoDot:1
+6 DO TERM^PXRMLDR(TERMIEN,.TERMARR)
+7 ;term evaulation
+8 SET FINDPA(0)=""
+9 DO IEVALTER^PXRMTERM(DFN,.FINDPA,.TERMARR,1,.FIEVAL)
+10 IF $DATA(^TMP(PXRMPID,$JOB,TERMIEN))
SET TFAIL=1
End DoDot:1
QUIT
+11 ;dialog branching logic process
+12 ;if Cache exist used results
+13 IF $DATA(^TMP($JOB,"PXRM DIALOG EVAL",DIALOGIEN,"TERM",TERMIEN))
Begin DoDot:1
+14 MERGE FIEVAL=^TMP($JOB,"PXRM DIALOG EVAL",DIALOGIEN,"TERM",TERMIEN,"FIEVAL")
+15 MERGE CDFIEVAL=^TMP($JOB,"PXRM DIALOG EVAL",DIALOGIEN,"TERM",TERMIEN,"CDFIEVAL")
End DoDot:1
QUIT
+16 ;build term array
+17 DO TERM^PXRMLDR(TERMIEN,.TERMARR)
+18 IF '$DATA(PXRMSRCFF)
SET PXRMSRCFF=1
SET CLEAN=1
+19 ;term evaluation
+20 SET FINDPA(0)=""
+21 DO IEVALTER^PXRMTERM(DFN,.FINDPA,.TERMARR,1,.FIEVAL)
+22 IF $DATA(^TMP(PXRMPID,$JOB,TERMIEN))
SET TFAIL=1
QUIT
+23 MERGE ^TMP($JOB,"PXRM DIALOG EVAL",DIALOGIEN,"TERM",TERMIEN,"FIEVAL")=FIEVAL
+24 IF $PIECE($GET(^PXRMD(801.41,IEN,0)),U,16)'["CRGF"
QUIT
+25 IF $DATA(^TMP($JOB,"PXRM DIALOG EVAL",DIALOGIEN,"TERM",TERMIEN,"CDFIEVAL"))
MERGE CDFIEVAL=^TMP($JOB,"PXRM DIALOG EVAL",DIALOGIEN,"TERM",TERMIEN,"CDFIEVAL")
QUIT
+26 MERGE CDFIEVAL=^TMP("PXRM BL DATA",$JOB,"FIEVAL")
IF CLEAN
KILL ^TMP("PXRM BL DATA",$JOB),PXRMSRCFF
+27 MERGE ^TMP($JOB,"PXRM DIALOG EVAL",DIALOGIEN,"TERM",TERMIEN,"CDFIEVAL")=CDFIEVAL
+28 QUIT
+29 ;
FINDGFIN(IEN,PKG,FINDINGS) ; Return list of GENERAL FINDINGS in dialog
+1 IF IEN'>0
QUIT
+2 NEW CIEN,FINDING,AFIEN
+3 SET CIEN=0
FOR
SET CIEN=$ORDER(^PXRMD(801.41,IEN,10,CIEN))
if '+CIEN
QUIT
Begin DoDot:1
+4 IF $PIECE(^PXRMD(801.41,IEN,10,CIEN,0),U,2)'=""
DO FINDGFIN($PIECE(^PXRMD(801.41,IEN,10,CIEN,0),U,2),PKG,.FINDINGS)
End DoDot:1
+5 SET FINDING=$PIECE($GET(^PXRMD(801.41,IEN,1)),U,5)
+6 IF FINDING[";PXRMD(801.46,"
IF $DATA(^PXRMD(801.46,+FINDING))>9
Begin DoDot:1
+7 DO FINDDATA(+FINDING,PKG,.FINDINGS)
End DoDot:1
+8 SET AFIEN=0
FOR
SET AFIEN=$ORDER(^PXRMD(801.41,IEN,3,AFIEN))
if '+AFIEN
QUIT
Begin DoDot:1
+9 SET FINDING=$PIECE($GET(^PXRMD(801.41,IEN,3,AFIEN,0)),U)
+10 IF FINDING[";PXRMD(801.46,"
IF $DATA(^PXRMD(801.46,+FINDING))>9
Begin DoDot:2
+11 DO FINDDATA(+FINDING,PKG,.FINDINGS)
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
FINDDATA(FIND,PKG,FINDINGS) ;
+1 NEW FILE,FIELD,NDATA,NODE,CID,SUB,TYPE,X
+2 SET FILE=$PIECE($GET(^PXRMD(801.46,FIND,0)),U,3)
IF FILE=""
QUIT
+3 IF $PIECE($GET(^PXRMD(801.46,FIND,0)),U,2)'=PKG
QUIT
+4 SET NODE=$GET(^PXRMD(801.46,FIND,3))
+5 SET NDATA=$PIECE(NODE,U,2)
IF NDATA=1
QUIT
+6 SET CID=$PIECE(NODE,U,3)
SET TYPE=$PIECE(NODE,U)
+7 FOR X=1,2
Begin DoDot:1
+8 SET NODE=$GET(^PXRMD(801.46,FIND,X))
+9 SET SUB=$PIECE(NODE,U,3)
if SUB=""
QUIT
+10 SET FINDINGS(SUB)=FILE_U_$PIECE(NODE,U,2)_U_TYPE_U_CID_U_PKG
+11 IF CID
SET FINDINGS("PXRM CID INDEX",$PIECE(NODE,U,3))=""
End DoDot:1
+12 QUIT
+13 ;
WH(FIEVAL) ;
+1 NEW ARRAY,DATE,ESUB,IDENT,DATE,NODE,STR,WVIEN
+2 SET IDENT=$PIECE($GET(^PXRMD(801.41,DITEM,0)),U,16)
+3 IF $GET(FIEVAL(1,"LINK"))=1
IF $GET(FIEVAL(1,"STATUS"))="OPEN"
IF $GET(FIEVAL(1,"VALUE"))="Pending"
Begin DoDot:1
+4 SET WVIEN=$GET(FIEVAL(1,"WVIEN"))
+5 DO RESULTS^WVALERTS(.ARRAY,WVIEN)
Begin DoDot:2
+6 KILL WHFIND,WHNAME
+7 SET NODE=$GET(ARRAY(0))
IF +$PIECE(NODE,U)'>0
QUIT
+8 SET WHFIND=WVIEN_";WV(790.1,"
SET WHNAME=$PIECE($GET(NODE),U,3)
+9 SET (ESUB,SUB)=0
FOR
SET SUB=$ORDER(DTXT(SUB))
if SUB'>0
QUIT
SET ESUB=SUB
+10 SET ESUB=ESUB+1
+11 IF IDENT="WHRP"
Begin DoDot:3
+12 NEW MOD
+13 SET DATE=""
+14 SET DTXT(ESUB)=$PIECE($GET(NODE),U,3)
SET ESUB=ESUB+1
+15 SET DATE=$PIECE($GET(NODE),U,4)
SET STR=$$RJ^XLFSTR("Collected: ",20)
+16 SET STR=STR_$PIECE($GET(NODE),U,8)
+17 SET DTXT(ESUB)=STR
SET ESUB=ESUB+1
+18 SET STR=$$RJ^XLFSTR("Lab Accession #: ",20)
SET STR=STR_$PIECE($GET(NODE),U,9)
+19 SET DTXT(ESUB)=STR
SET ESUB=ESUB+1
+20 SET STR=$$RJ^XLFSTR("Specimen: ",20)
SET STR=STR_$PIECE($GET(NODE),U,10)
+21 SET DTXT(ESUB)=STR
End DoDot:3
+22 IF IDENT="WHRM"
Begin DoDot:3
+23 SET STR=$$RJ^XLFSTR("Procedure: ",20)
SET STR=STR_$PIECE($GET(NODE),U,5)
+24 SET DTXT(ESUB)=STR
SET ESUB=ESUB+1
+25 SET STR=$$RJ^XLFSTR("Primary Diagnosis: ",20)
SET STR=STR_$PIECE($GET(NODE),U,6)
+26 SET DTXT(ESUB)=STR
SET ESUB=ESUB+1
+27 SET STR=$$RJ^XLFSTR("Modifiers: ",20)
SET MOD=$PIECE($GET(NODE),U,7)
+28 IF $GET(MOD)=""
SET STR=STR_"<none>"
+29 IF '$TEST
SET STR=STR_$PIECE($GET(MOD),"~",1)
+30 SET DTXT(ESUB)=STR
SET ESUB=ESUB+1
+31 IF $PIECE($GET(MOD),"~",2)'=""
SET DTXT(ESUB)=$$LJ^XLFSTR($PIECE(MOD,"~",2),23)
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT
+33 ;
