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

PXRMDLLB.m

Go to the documentation of this file.
PXRMDLLB ;SLC/PJH - REMINDER DIALOG LOADER;09/18/2019
 ;;2.0;CLINICAL REMINDERS;**6,12,16,26,47,45**;Feb 04, 2005;Build 566
 ;
CODES(TXIEN,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=$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)
 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 EXP(DITEM,TIEN,DCUR,"CPT",3,NDATA)
 I "NP"[TSEL 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
 I DTTYP="" Q
 ;S FILE=$S(DTTYP="POV":80,DTTYP="CPT":81,1:"") Q:'FILE
 S LIT="Selectable "_$S(DTTYP="POV":"Diagnoses:",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)
 ;I FILE=80 S CODETYPE("ICD")="",CODETYPE("10D")=""
 ;I FILE=81 S CODETYPE("CPT")=""
 S OCNT=OCNT+1
 I TYPE=5 D
 .S ORY(OCNT)=3_U_DITEM_U_U_DTTYP_U_1_U_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,.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
 ;
 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
 ;Pass MST code as a forced value
MST(DFTYP,DFIEN) ;
 ;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 ACTION'="H" 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)
 ;S SUB=$O(DTXT(""),-1)+1
 ;K FIEVAL M FIEVAL=^TMP("PXRM BL DATA",$J,"FIEVAL") K ^TMP("PXRM BL DATA",$J)
 ;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)
 .;S FINDINGS($P(NODE,U,3))=FILE_U_$P(NODE,U,2)_U_TYPE_U_CID
 .;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
 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)
 ;K FIEVAL,PXRMDEFS
 D EVAL^PXRM(DFN,.DEFARR,5,1,.FIEVAL,DT)
 S RSTAT=$P($G(^TMP("PXRHM",$J,RIEN,RNAME)),U)
 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 TERMARR,PXRMITEM,PXRMPID,CLEAN
 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
 .D IEVALTER^PXRMTERM(DFN,.TERMARR,.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 evaulation
 D IEVALTER^PXRMTERM(DFN,.TERMARR,.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"))
 .;DBIA #4102
 .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
 ;