- 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 Jan 18, 2025@02:45:18 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 ;