PXRMDBL2 ; SLC/PJH - Reminder Dialog Generation. ;05/08/2000
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;
;Process individual finding
;--------------------------
FIND(DATA) ;
;Determine finding type
S FGLOB=$P($P(DATA,U),";",2) Q:FGLOB=""
S FITEM=$P(DATA,";") Q:FITEM=""
S FTYP=$G(DEF1(FGLOB)) Q:FTYP=""
;Get resolution item (same as finding item)
S RESN=$P(DATA,U)
;Mental Health Test
I FTYP="MH" Q:'$$MHOK^PXRMDBL3(FITEM)
;Check if an entry exists in the finding item dialog file
I $D(^PXRMD(801.43,"AC",RESN)) D Q:DIEN
.S DIEN=$$OK(RESN) Q:'DIEN
.;Create entry in array used to build reminder dialog
.S CNT=CNT+1,ARRAY(CNT)=801.43_U_DIEN
.W !!,CNT,?5,"Finding item dialog "_$$FNAM(RESN)
;
;Determine names/text for non-taxonomy/orderable item findings
I (FTYP'="TX")&(FTYP'="OI") D
.I FTYP="ED" S INAME=$$NAME(FGLOB,FITEM,4)
.I FTYP="VM" S INAME=$$NAME(FGLOB,FITEM,1)
.I (FTYP'="ED")&(FTYP'="VM") S INAME=$$NAME(FGLOB,FITEM,2)
.;Dialog item name root
.S DNAME=FTYP_" "_INAME
.;Create array entry for each resolution defined in #801.45
.D RESOL(FTYP,0)
;
;Determine names/text for orderable item findings
I FTYP="OI" D
.S INAME=$$NAME(FGLOB,FITEM,1)
.;Dialog item name root
.S DNAME=FTYP_" "_INAME
.;Create array entry
.D RESOL(FTYP,0)
;
;Determine names/text for taxonomy findings
I FTYP="TX" S INAME=$$NAME(FGLOB,FITEM,2) D TAXON
Q
;
;Get Finding Item name
;---------------------
FNAM(FIND) ;
N DATA,NAME,NODE
S NAME="Unknown"
S NODE=$O(^PXRMD(801.43,"AC",FIND,"")) Q:'NODE NAME
S DATA=$G(^PXRMD(801.43,NODE,0)) Q:DATA="" NAME
I $P(DATA,U)'="" S NAME=$P(DATA,U)
S GLOB=$P($P(FIND,U),";",2) S:GLOB]"" NAME=$G(DEF1(GLOB))_" - "_NAME
Q NAME
;
;additional prompts in 801.45
;----------------------------
FPROMPT(FNODE,RSUB,CNT,ARRAY) ;
;Get all additional fields for this resolution type
N ACNT,ASUB,ATXT,DNODE,RDATA,REXC,ROVR,RREQ,RSNL
S ASUB=0,ACNT=0
F S ASUB=$O(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB)) Q:'ASUB D
.S RDATA=$G(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB,0)) Q:RDATA=""
.;Ignore if disabled
.I $P(RDATA,U,3)=1 Q
.S DNODE=$P(RDATA,U) Q:DNODE=""
.S ATXT=$P($G(^PXRMD(801.41,DNODE,0)),U) Q:ATXT=""
.S REXC=$P(RDATA,U,7),RSNL=$P(RDATA,U,6)
.S ROVR=$P(RDATA,U,5),RREQ=$P(RDATA,U,2)
.;S ATXT=$TR(ATXT,UPPER,LOWER)
.S ACNT=ACNT+1
.S ARRAY(CNT,ACNT)=DNODE_U_ROVR_U_RSNL_U_REXC_U_RREQ
Q
;
;Health Factor Resolutions
;-------------------------
HF(RNODE) ;
;Defined in #801.95
I $D(^PXRMD(801.95,$P(RESN,";"),1,"B",RNODE)) Q 1
;Check for local statuses if this is a national code (restricted edit)
N FOUND,LSUB S FOUND=0,LSUB=""
I $P($G(^PXRMD(801.9,RNODE,0)),U,6)=1 D
.F S LSUB=$O(^PXRMD(801.9,RNODE,10,"B",LSUB)) Q:'LSUB D Q:FOUND
..S:$D(^PXRMD(801.95,$P(RESN,";"),1,"B",LSUB)) FOUND=1
Q FOUND
;
;Returns item name
;-----------------
NAME(FGLOB,FITEM,POSN) ;
N NAME
S FGLOB=U_FGLOB_FITEM_",0)"
S NAME=$P($G(@FGLOB),U,POSN)
I NAME]"" D
.I FGLOB["ICD9(" S NAME=$P($$ICDDX^ICDCODE(FITEM,""),U,2)
.I FGLOB["ICPT(" S NAME=$P($$CPT^ICPTCOD(FITEM,""),U,2)_" "_$TR(NAME,LOWER,UPPER)
.;I FGLOB["ICD9(" S NAME=NAME_" ("_$P($G(@FGLOB),U)_")"
.;I FGLOB["ICPT(" S NAME=$P($G(@FGLOB),U)_" "_$TR(NAME,LOWER,UPPER)
I NAME="" S NAME=$P($G(@FGLOB),U)
I NAME="" S NAME=FITEM
Q NAME
;
;Checks if an enabled finding item dialog exists
;-----------------------------------------------
OK(FIND) ;
N DATA,DIEN,DTYP,NODE
S NODE=$O(^PXRMD(801.43,"AC",FIND,"")) Q:'NODE 0
S DATA=$G(^PXRMD(801.43,NODE,0)) Q:DATA="" 0
;Ignore disabled entries
I $P(DATA,U,3) Q 0
;Ignore finding item dialogs no longer valid
S DIEN=$P(DATA,U,4) Q:DIEN="" 0
S DATA=$G(^PXRMD(801.41,DIEN,0)) Q:DATA="" 0
;Ignore disabled dialogs
I $P(DATA,U,3)=1 Q 0
;Return dialog ien
Q DIEN
;
;Create array for each resolution status
;---------------------------------------
RESOL(TYP,TAX) ;
; Predefined fields :
; PNAME - text used in prompt
; DNAME - text used in dialog item name
; RESN - finding item
;
; Taxonomies TYP=CPT or POV and TAX=1 or 0
; Others TAX=0 (ie: 1 prompt per code)
;
;Get parameter file node for this finding type
S FNODE=$O(^PXRMD(801.45,"B",TYP,"")) Q:FNODE=""
;Get each resolution type for this finding type
S RSUB=0
F S RSUB=$O(^PXRMD(801.45,FNODE,1,RSUB)) Q:'RSUB D
.;Check if resolution type is disabled
.I $P($G(^PXRMD(801.45,FNODE,1,RSUB,0)),U,2)=1 Q
.;Construct name for this resolution type
.S RNODE=$P($G(^PXRMD(801.45,FNODE,1,RSUB,0)),U),RNAME=""
.I RNODE S RNAME=$P($G(^PXRMD(801.9,RNODE,0)),U,2)
.I RNAME="" S RNAME=$P($G(^PXRMD(801.9,RNODE,0)),U)
.;Validate resolution
.I TYP="HF" Q:'$$HF(RNODE)
.W !
.;Create arrays
.S CNT=CNT+1
.;Convert dialog item name to UC
.S DNAME=$TR(DNAME,LOWER,UPPER)
.;Truncate the item name - without finesse
.S DSHORT=DNAME_" "_RNAME
.I $L(DSHORT)>63 S DSHORT=$E(DNAME,1,53)_" "_$E(RNAME,1,9)
.;Dialog item name,resolution status and finding item
.I TYP'="OI" S ARRAY(CNT)=DSHORT_U_RNODE_U_RESN_U
.;For orderable items the finding field is empty
.I TYP="OI" S ARRAY(CNT)=DSHORT_U_RNODE_U_U_$P(RESN,";")
.;Append prefix and suffix if NOT a condensed taxonomy
.S PNAME=INAME
.I 'TAX D
..;Prefix text
..S RPRE=$G(^PXRMD(801.45,FNODE,1,RSUB,3)) I RPRE]"" S RPRE=RPRE_" "
..;Suffix text
..S RSUF=$G(^PXRMD(801.45,FNODE,1,RSUB,4))
..I (RSUF]"")&($E(RSUF)'=".") S RSUF=" "_RSUF
..;Prompt text
..S PNAME=RPRE_$TR(INAME,UPPER,LOWER)_RSUF
..;Convert first character
..S $E(PNAME)=$TR($E(PNAME),LOWER,UPPER)
.;Prompt text
.S WPTXT(CNT,1)=PNAME
.;test
.W !,CNT,?5,WPTXT(CNT,1)
.;Additional prompts from general finding parameters
.D FPROMPT(FNODE,RSUB,CNT,.ARRAY)
Q
;
;Taxonomy Dialog in #801.2
;-------------------------
TAXON ;
S TDPAR=$G(^PXD(811.2,FITEM,"SDZ")),TDTXT="",TDHTXT=""
S TPPAR=$G(^PXD(811.2,FITEM,"SDZ")),TPTXT="",TPHTXT=""
S TDMOD=$P(TDPAR,U,1),TPMOD=$P(TPPAR,U,1)
;Check what type of taxonomy codes exist
S TDX=$O(^PXD(811.2,FITEM,80,0))
S TPR=$O(^PXD(811.2,FITEM,81,0))
;
;If taxonomy is to be presented as checkbox(s)
I ('TDMOD)!('TPMOD) D
.S DNAME=FTYP_" "_INAME
.;Create arrays
.S CNT=CNT+1
.;Convert dialog item name to UC
.S DNAME=$TR(DNAME,LOWER,UPPER)
.;Truncate the item name - without finesse
.S DSHORT=DNAME
.I $L(DSHORT)>40 S DSHORT=$E(DNAME,1,40)
.;Dialog item name and finding item
.S ARRAY(CNT)=DSHORT_U_U_RESN
.;Prompt text
.S WPTXT(CNT,1)=INAME
.W !!,CNT,?5,WPTXT(CNT,1)
;
;Individual Diagnoses
I TDX,TDMOD D
.N NLINES,CODE,OUTPUT
.S TSEQ=0,TTYP="POV"
.F S TSEQ=$O(^PXD(811.2,FITEM,"SDX","B",TSEQ)) Q:'TSEQ D
..S TSUB=$O(^PXD(811.2,FITEM,"SDX","B",TSEQ,"")) Q:'TSUB
..S DATA=$G(^PXD(811.2,FITEM,"SDX",TSUB,0)) Q:DATA=""
..S TITEM=$P(DATA,U) Q:'TITEM
..;Ignore if disabled
..Q:$P(DATA,U,3)=1
..;Resolution becomes the diagnosis
..S RESN=TITEM_";ICD9("
..;Take prompt from user defined text
..S INAME=$P(DATA,U,2)
..;Otherwise use name of diagnosis
..S CODE=$$ICDDX^ICDCODE(TITEM,"")
..S NLINES=$$ICDD^ICDCODE($G(CODE),"OUTPUT","")
..S INAME=$G(OUTPUT(1))
..I INAME="" S FGLOB="ICD9(",INAME=$$NAME(FGLOB,TITEM,3)
..;Dialog Item name root
..S DNAME="POV "_INAME
..;Create array entry for each resolution defined in #801.45
..D RESOL(TTYP,0)
;
;Individual Procedures
I TPR,TPMOD D
.S TSEQ=0,TTYP="CPT"
.F S TSEQ=$O(^PXD(811.2,FITEM,"SPR","B",TSEQ)) Q:'TSEQ D
..S TSUB=$O(^PXD(811.2,FITEM,"SPR","B",TSEQ,"")) Q:'TSUB
..S DATA=$G(^PXD(811.2,FITEM,"SPR",TSUB,0)) Q:DATA=""
..S TITEM=$P(DATA,U) Q:'TITEM
..;Ignore if disabled
..Q:$P(DATA,U,3)=1
..;Resolution becomes the procedure
..S RESN=TITEM_";ICPT("
..;Take prompt from user defined text
..S INAME=$P(DATA,U,2)
..;Otherwise use name of procedure
..I INAME="" S FGLOB="ICPT(",INAME=$$NAME(FGLOB,TITEM,2)
..;Dialog Item name root
..S DNAME="CPT "_INAME
..;Create array entry for each resolution defined in #801.45
..D RESOL(TTYP,0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMDBL2 8095 printed Dec 13, 2024@01:43:33 Page 2
PXRMDBL2 ; SLC/PJH - Reminder Dialog Generation. ;05/08/2000
+1 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+2 ;
+3 ;Process individual finding
+4 ;--------------------------
FIND(DATA) ;
+1 ;Determine finding type
+2 SET FGLOB=$PIECE($PIECE(DATA,U),";",2)
if FGLOB=""
QUIT
+3 SET FITEM=$PIECE(DATA,";")
if FITEM=""
QUIT
+4 SET FTYP=$GET(DEF1(FGLOB))
if FTYP=""
QUIT
+5 ;Get resolution item (same as finding item)
+6 SET RESN=$PIECE(DATA,U)
+7 ;Mental Health Test
+8 IF FTYP="MH"
if '$$MHOK^PXRMDBL3(FITEM)
QUIT
+9 ;Check if an entry exists in the finding item dialog file
+10 IF $DATA(^PXRMD(801.43,"AC",RESN))
Begin DoDot:1
+11 SET DIEN=$$OK(RESN)
if 'DIEN
QUIT
+12 ;Create entry in array used to build reminder dialog
+13 SET CNT=CNT+1
SET ARRAY(CNT)=801.43_U_DIEN
+14 WRITE !!,CNT,?5,"Finding item dialog "_$$FNAM(RESN)
End DoDot:1
if DIEN
QUIT
+15 ;
+16 ;Determine names/text for non-taxonomy/orderable item findings
+17 IF (FTYP'="TX")&(FTYP'="OI")
Begin DoDot:1
+18 IF FTYP="ED"
SET INAME=$$NAME(FGLOB,FITEM,4)
+19 IF FTYP="VM"
SET INAME=$$NAME(FGLOB,FITEM,1)
+20 IF (FTYP'="ED")&(FTYP'="VM")
SET INAME=$$NAME(FGLOB,FITEM,2)
+21 ;Dialog item name root
+22 SET DNAME=FTYP_" "_INAME
+23 ;Create array entry for each resolution defined in #801.45
+24 DO RESOL(FTYP,0)
End DoDot:1
+25 ;
+26 ;Determine names/text for orderable item findings
+27 IF FTYP="OI"
Begin DoDot:1
+28 SET INAME=$$NAME(FGLOB,FITEM,1)
+29 ;Dialog item name root
+30 SET DNAME=FTYP_" "_INAME
+31 ;Create array entry
+32 DO RESOL(FTYP,0)
End DoDot:1
+33 ;
+34 ;Determine names/text for taxonomy findings
+35 IF FTYP="TX"
SET INAME=$$NAME(FGLOB,FITEM,2)
DO TAXON
+36 QUIT
+37 ;
+38 ;Get Finding Item name
+39 ;---------------------
FNAM(FIND) ;
+1 NEW DATA,NAME,NODE
+2 SET NAME="Unknown"
+3 SET NODE=$ORDER(^PXRMD(801.43,"AC",FIND,""))
if 'NODE
QUIT NAME
+4 SET DATA=$GET(^PXRMD(801.43,NODE,0))
if DATA=""
QUIT NAME
+5 IF $PIECE(DATA,U)'=""
SET NAME=$PIECE(DATA,U)
+6 SET GLOB=$PIECE($PIECE(FIND,U),";",2)
if GLOB]""
SET NAME=$GET(DEF1(GLOB))_" - "_NAME
+7 QUIT NAME
+8 ;
+9 ;additional prompts in 801.45
+10 ;----------------------------
FPROMPT(FNODE,RSUB,CNT,ARRAY) ;
+1 ;Get all additional fields for this resolution type
+2 NEW ACNT,ASUB,ATXT,DNODE,RDATA,REXC,ROVR,RREQ,RSNL
+3 SET ASUB=0
SET ACNT=0
+4 FOR
SET ASUB=$ORDER(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB))
if 'ASUB
QUIT
Begin DoDot:1
+5 SET RDATA=$GET(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB,0))
if RDATA=""
QUIT
+6 ;Ignore if disabled
+7 IF $PIECE(RDATA,U,3)=1
QUIT
+8 SET DNODE=$PIECE(RDATA,U)
if DNODE=""
QUIT
+9 SET ATXT=$PIECE($GET(^PXRMD(801.41,DNODE,0)),U)
if ATXT=""
QUIT
+10 SET REXC=$PIECE(RDATA,U,7)
SET RSNL=$PIECE(RDATA,U,6)
+11 SET ROVR=$PIECE(RDATA,U,5)
SET RREQ=$PIECE(RDATA,U,2)
+12 ;S ATXT=$TR(ATXT,UPPER,LOWER)
+13 SET ACNT=ACNT+1
+14 SET ARRAY(CNT,ACNT)=DNODE_U_ROVR_U_RSNL_U_REXC_U_RREQ
End DoDot:1
+15 QUIT
+16 ;
+17 ;Health Factor Resolutions
+18 ;-------------------------
HF(RNODE) ;
+1 ;Defined in #801.95
+2 IF $DATA(^PXRMD(801.95,$PIECE(RESN,";"),1,"B",RNODE))
QUIT 1
+3 ;Check for local statuses if this is a national code (restricted edit)
+4 NEW FOUND,LSUB
SET FOUND=0
SET LSUB=""
+5 IF $PIECE($GET(^PXRMD(801.9,RNODE,0)),U,6)=1
Begin DoDot:1
+6 FOR
SET LSUB=$ORDER(^PXRMD(801.9,RNODE,10,"B",LSUB))
if 'LSUB
QUIT
Begin DoDot:2
+7 if $DATA(^PXRMD(801.95,$PIECE(RESN,";"),1,"B",LSUB))
SET FOUND=1
End DoDot:2
if FOUND
QUIT
End DoDot:1
+8 QUIT FOUND
+9 ;
+10 ;Returns item name
+11 ;-----------------
NAME(FGLOB,FITEM,POSN) ;
+1 NEW NAME
+2 SET FGLOB=U_FGLOB_FITEM_",0)"
+3 SET NAME=$PIECE($GET(@FGLOB),U,POSN)
+4 IF NAME]""
Begin DoDot:1
+5 IF FGLOB["ICD9("
SET NAME=$PIECE($$ICDDX^ICDCODE(FITEM,""),U,2)
+6 IF FGLOB["ICPT("
SET NAME=$PIECE($$CPT^ICPTCOD(FITEM,""),U,2)_" "_$TRANSLATE(NAME,LOWER,UPPER)
+7 ;I FGLOB["ICD9(" S NAME=NAME_" ("_$P($G(@FGLOB),U)_")"
+8 ;I FGLOB["ICPT(" S NAME=$P($G(@FGLOB),U)_" "_$TR(NAME,LOWER,UPPER)
End DoDot:1
+9 IF NAME=""
SET NAME=$PIECE($GET(@FGLOB),U)
+10 IF NAME=""
SET NAME=FITEM
+11 QUIT NAME
+12 ;
+13 ;Checks if an enabled finding item dialog exists
+14 ;-----------------------------------------------
OK(FIND) ;
+1 NEW DATA,DIEN,DTYP,NODE
+2 SET NODE=$ORDER(^PXRMD(801.43,"AC",FIND,""))
if 'NODE
QUIT 0
+3 SET DATA=$GET(^PXRMD(801.43,NODE,0))
if DATA=""
QUIT 0
+4 ;Ignore disabled entries
+5 IF $PIECE(DATA,U,3)
QUIT 0
+6 ;Ignore finding item dialogs no longer valid
+7 SET DIEN=$PIECE(DATA,U,4)
if DIEN=""
QUIT 0
+8 SET DATA=$GET(^PXRMD(801.41,DIEN,0))
if DATA=""
QUIT 0
+9 ;Ignore disabled dialogs
+10 IF $PIECE(DATA,U,3)=1
QUIT 0
+11 ;Return dialog ien
+12 QUIT DIEN
+13 ;
+14 ;Create array for each resolution status
+15 ;---------------------------------------
RESOL(TYP,TAX) ;
+1 ; Predefined fields :
+2 ; PNAME - text used in prompt
+3 ; DNAME - text used in dialog item name
+4 ; RESN - finding item
+5 ;
+6 ; Taxonomies TYP=CPT or POV and TAX=1 or 0
+7 ; Others TAX=0 (ie: 1 prompt per code)
+8 ;
+9 ;Get parameter file node for this finding type
+10 SET FNODE=$ORDER(^PXRMD(801.45,"B",TYP,""))
if FNODE=""
QUIT
+11 ;Get each resolution type for this finding type
+12 SET RSUB=0
+13 FOR
SET RSUB=$ORDER(^PXRMD(801.45,FNODE,1,RSUB))
if 'RSUB
QUIT
Begin DoDot:1
+14 ;Check if resolution type is disabled
+15 IF $PIECE($GET(^PXRMD(801.45,FNODE,1,RSUB,0)),U,2)=1
QUIT
+16 ;Construct name for this resolution type
+17 SET RNODE=$PIECE($GET(^PXRMD(801.45,FNODE,1,RSUB,0)),U)
SET RNAME=""
+18 IF RNODE
SET RNAME=$PIECE($GET(^PXRMD(801.9,RNODE,0)),U,2)
+19 IF RNAME=""
SET RNAME=$PIECE($GET(^PXRMD(801.9,RNODE,0)),U)
+20 ;Validate resolution
+21 IF TYP="HF"
if '$$HF(RNODE)
QUIT
+22 WRITE !
+23 ;Create arrays
+24 SET CNT=CNT+1
+25 ;Convert dialog item name to UC
+26 SET DNAME=$TRANSLATE(DNAME,LOWER,UPPER)
+27 ;Truncate the item name - without finesse
+28 SET DSHORT=DNAME_" "_RNAME
+29 IF $LENGTH(DSHORT)>63
SET DSHORT=$EXTRACT(DNAME,1,53)_" "_$EXTRACT(RNAME,1,9)
+30 ;Dialog item name,resolution status and finding item
+31 IF TYP'="OI"
SET ARRAY(CNT)=DSHORT_U_RNODE_U_RESN_U
+32 ;For orderable items the finding field is empty
+33 IF TYP="OI"
SET ARRAY(CNT)=DSHORT_U_RNODE_U_U_$PIECE(RESN,";")
+34 ;Append prefix and suffix if NOT a condensed taxonomy
+35 SET PNAME=INAME
+36 IF 'TAX
Begin DoDot:2
+37 ;Prefix text
+38 SET RPRE=$GET(^PXRMD(801.45,FNODE,1,RSUB,3))
IF RPRE]""
SET RPRE=RPRE_" "
+39 ;Suffix text
+40 SET RSUF=$GET(^PXRMD(801.45,FNODE,1,RSUB,4))
+41 IF (RSUF]"")&($EXTRACT(RSUF)'=".")
SET RSUF=" "_RSUF
+42 ;Prompt text
+43 SET PNAME=RPRE_$TRANSLATE(INAME,UPPER,LOWER)_RSUF
+44 ;Convert first character
+45 SET $EXTRACT(PNAME)=$TRANSLATE($EXTRACT(PNAME),LOWER,UPPER)
End DoDot:2
+46 ;Prompt text
+47 SET WPTXT(CNT,1)=PNAME
+48 ;test
+49 WRITE !,CNT,?5,WPTXT(CNT,1)
+50 ;Additional prompts from general finding parameters
+51 DO FPROMPT(FNODE,RSUB,CNT,.ARRAY)
End DoDot:1
+52 QUIT
+53 ;
+54 ;Taxonomy Dialog in #801.2
+55 ;-------------------------
TAXON ;
+1 SET TDPAR=$GET(^PXD(811.2,FITEM,"SDZ"))
SET TDTXT=""
SET TDHTXT=""
+2 SET TPPAR=$GET(^PXD(811.2,FITEM,"SDZ"))
SET TPTXT=""
SET TPHTXT=""
+3 SET TDMOD=$PIECE(TDPAR,U,1)
SET TPMOD=$PIECE(TPPAR,U,1)
+4 ;Check what type of taxonomy codes exist
+5 SET TDX=$ORDER(^PXD(811.2,FITEM,80,0))
+6 SET TPR=$ORDER(^PXD(811.2,FITEM,81,0))
+7 ;
+8 ;If taxonomy is to be presented as checkbox(s)
+9 IF ('TDMOD)!('TPMOD)
Begin DoDot:1
+10 SET DNAME=FTYP_" "_INAME
+11 ;Create arrays
+12 SET CNT=CNT+1
+13 ;Convert dialog item name to UC
+14 SET DNAME=$TRANSLATE(DNAME,LOWER,UPPER)
+15 ;Truncate the item name - without finesse
+16 SET DSHORT=DNAME
+17 IF $LENGTH(DSHORT)>40
SET DSHORT=$EXTRACT(DNAME,1,40)
+18 ;Dialog item name and finding item
+19 SET ARRAY(CNT)=DSHORT_U_U_RESN
+20 ;Prompt text
+21 SET WPTXT(CNT,1)=INAME
+22 WRITE !!,CNT,?5,WPTXT(CNT,1)
End DoDot:1
+23 ;
+24 ;Individual Diagnoses
+25 IF TDX
IF TDMOD
Begin DoDot:1
+26 NEW NLINES,CODE,OUTPUT
+27 SET TSEQ=0
SET TTYP="POV"
+28 FOR
SET TSEQ=$ORDER(^PXD(811.2,FITEM,"SDX","B",TSEQ))
if 'TSEQ
QUIT
Begin DoDot:2
+29 SET TSUB=$ORDER(^PXD(811.2,FITEM,"SDX","B",TSEQ,""))
if 'TSUB
QUIT
+30 SET DATA=$GET(^PXD(811.2,FITEM,"SDX",TSUB,0))
if DATA=""
QUIT
+31 SET TITEM=$PIECE(DATA,U)
if 'TITEM
QUIT
+32 ;Ignore if disabled
+33 if $PIECE(DATA,U,3)=1
QUIT
+34 ;Resolution becomes the diagnosis
+35 SET RESN=TITEM_";ICD9("
+36 ;Take prompt from user defined text
+37 SET INAME=$PIECE(DATA,U,2)
+38 ;Otherwise use name of diagnosis
+39 SET CODE=$$ICDDX^ICDCODE(TITEM,"")
+40 SET NLINES=$$ICDD^ICDCODE($GET(CODE),"OUTPUT","")
+41 SET INAME=$GET(OUTPUT(1))
+42 IF INAME=""
SET FGLOB="ICD9("
SET INAME=$$NAME(FGLOB,TITEM,3)
+43 ;Dialog Item name root
+44 SET DNAME="POV "_INAME
+45 ;Create array entry for each resolution defined in #801.45
+46 DO RESOL(TTYP,0)
End DoDot:2
End DoDot:1
+47 ;
+48 ;Individual Procedures
+49 IF TPR
IF TPMOD
Begin DoDot:1
+50 SET TSEQ=0
SET TTYP="CPT"
+51 FOR
SET TSEQ=$ORDER(^PXD(811.2,FITEM,"SPR","B",TSEQ))
if 'TSEQ
QUIT
Begin DoDot:2
+52 SET TSUB=$ORDER(^PXD(811.2,FITEM,"SPR","B",TSEQ,""))
if 'TSUB
QUIT
+53 SET DATA=$GET(^PXD(811.2,FITEM,"SPR",TSUB,0))
if DATA=""
QUIT
+54 SET TITEM=$PIECE(DATA,U)
if 'TITEM
QUIT
+55 ;Ignore if disabled
+56 if $PIECE(DATA,U,3)=1
QUIT
+57 ;Resolution becomes the procedure
+58 SET RESN=TITEM_";ICPT("
+59 ;Take prompt from user defined text
+60 SET INAME=$PIECE(DATA,U,2)
+61 ;Otherwise use name of procedure
+62 IF INAME=""
SET FGLOB="ICPT("
SET INAME=$$NAME(FGLOB,TITEM,2)
+63 ;Dialog Item name root
+64 SET DNAME="CPT "_INAME
+65 ;Create array entry for each resolution defined in #801.45
+66 DO RESOL(TTYP,0)
End DoDot:2
End DoDot:1
+67 QUIT
