PXRMDLG3 ;SLC/PJH - Reminder Dialog Edit/Inquiry ;03/27/2015 08:40
;;2.0;CLINICAL REMINDERS;**45**;Feb 04, 2005;Build 566
;
;
;Display national dialog
START N NLINE,NSEL
S NLINE=0,NSEL=0
;
;Group header
I $P($G(^PXRMD(801.41,PXRMDIEN,0)),U,4)="G" D
.D DLINE(PXRMDIEN,"","")
;Other components
D DETAIL(PXRMDIEN,"")
;Create headings
D CHGCAP^VALM("HEADER1","Item Seq.")
D CHGCAP^VALM("HEADER2","Dialog Details/Findings")
D CHGCAP^VALM("HEADER3","Type")
S VALMCNT=NLINE
S ^TMP("PXRMDLG",$J,"VALMCNT")=VALMCNT
EXIT Q
;
;Additional Findings
;-------------------
ADD(DIEN) ;
N FIND,FSUB,FTYP,FNAME,FNUM
S FSUB=0
F S FSUB=$O(^PXRMD(801.41,DIEN,3,FSUB)) Q:'FSUB D
.S FIND=$P($G(^PXRMD(801.41,DIEN,3,FSUB,0)),U) Q:FIND=""
.S FNAME="" D FDESC(FIND) Q:FNAME=""
.;Save additional finding name
.S FOUND=1 D SAVE(2,FNAME,FTYP)
Q
;
;Build listman global for all components
;---------------------------------------
DETAIL(PXRMDIEN,LEV) ;
N DDATA,DDLG,DEND,DIEN,DNAM,DSEQ,DSTRT,IND,JND,DSUB
S DSEQ=0
;
;Get each sequence number
F S DSEQ=$O(^PXRMD(801.41,PXRMDIEN,10,"B",DSEQ)) Q:'DSEQ D
.;Determine subscript
.S DSUB=$O(^PXRMD(801.41,PXRMDIEN,10,"B",DSEQ,"")) Q:'DSUB
.;Get ien of prompt/component
.S DIEN=$P($G(^PXRMD(801.41,PXRMDIEN,10,DSUB,0)),U,2) Q:'DIEN
.;Ignore prompts and forced values
.I "PF"[$P($G(^PXRMD(801.41,DIEN,0)),U,4) Q
.;Save line in workfile
.D DLINE(DIEN,LEV,DSEQ)
.;
.;Process any sub-components
.D DETAIL(DIEN,LEV_DSEQ_".")
.;Extra line feed
.I LEV="" D
..S NLINE=NLINE+1
..S ^TMP("PXRMDLG",$J,NLINE,0)=$J("",79)
Q
;
;Save individual component details
;---------------------------------
DLINE(DIEN,LEV,DSEQ) ;
;Dialog name
S DNAM=$P($G(^PXRMD(801.41,DIEN,0)),U) Q:DNAM=""
;Check if standard PXRM prompt
I $$PXRM^PXRMEXID(DNAM) Q
;
N DPTX,DTXT,DTYP,EXIST,ITEM,TEMP,SEP
S ITEM=""
S NSEL=NSEL+1,ITEM=NSEL
S NLINE=NLINE+1,SEP=$E(LEV,$L(LEV))
S TEMP=$J(ITEM,3)_$J("",4)_LEV_DSEQ
;Determine type
S DTYP=$S($P($G(^PXRMD(801.41,DIEN,0)),U,4)="G":"group",1:"element")
;Dialog component display
I $L(TEMP)<13 S TEMP=TEMP_$J("",12+$L(SEP)-$L(TEMP))_$E(DNAM,1,50)
E S TEMP=TEMP_" "_$E(DNAM,1,50)
;Add Type
S ^TMP("PXRMDLG",$J,NLINE,0)=TEMP_$J("",70-$L(TEMP))_DTYP
;
;Set up selection index
S ^TMP("PXRMDLG",$J,"IDX",NSEL,DIEN)=""
;
;Insert finding items
I ("element;group"[DTYP) D
.N DSUB,FDATA,FILENUM,FLIT,FLONG,FNAME,FOUND,FREP,FTAB,FTYP,TEMP
.;Findings
.S FNAME="",FOUND=0
.D FDESC($P($G(^PXRMD(801.41,DIEN,1)),U,5))
.I FNAME'="" S FOUND=1 D SAVE(1,FNAME,FTYP)
.;Additional findings (see ADD^PXRMDLG2)
.D ADD(DIEN)
.;If no findings
.I 'FOUND D
..S NLINE=NLINE+1
..S ^TMP("PXRMDLG",$J,NLINE,0)=$J("",12+$L(SEP))_"Finding: *NONE*"
Q
;
;Finding description
;-------------------
FDESC(FIEN) ;
N FGLOB,FITEM
;Determine finding type
S FGLOB=$P(FIEN,";",2) Q:FGLOB=""
S FITEM=$P(FIEN,";") Q:FITEM=""
;Diagnosis POV
I FGLOB["ICD9" D Q
.S FTYP="DIAGNOSIS",FGLOB=U_FGLOB_FITEM_",0)"
.S FNAME=$P($G(@FGLOB),U,3)
I FGLOB["WV" D Q
.S FTYP="WH NOTIFICATION PURPOSE",FGLOB=U_FGLOB_FITEM_",0)"
.S FNAME=$P($G(@FGLOB),U)
;Procedure CPT
I FGLOB["ICPT" D Q
.S FTYP="PROCEDURE",FGLOB=U_FGLOB_FITEM_",0)"
.S FNAME=$P($G(@FGLOB),U,2)
;Quick order
I FGLOB["ORD(101.41" D Q
.S FTYP="QUICK ORDER",FGLOB=U_FGLOB_FITEM_",0)"
.S FNAME=$P($G(@FGLOB),U,2)
I FGLOB["PXRMD(801.46" D Q
.S FTYP="GENERAL FINDING",FGLOB=U_FGLOB_FITEM_",0)"
.S FNAME=$P($G(@FGLOB),U)
;Short name for finding type
S FTYP=$G(DEF1(FGLOB)) Q:FTYP=""
;Long name
S FTYP=$G(DEF2(FTYP))
S FGLOB=U_FGLOB_FITEM_",0)"
S FNAME=$P($G(@FGLOB),U,1)
I FNAME="" S FNAME=$P($G(@FGLOB),U)
I FNAME]"" S FNAME=FNAME Q
S FNAME=FITEM
Q
;
;Save finding details
;--------------------
SAVE(DSUB,FNAME,FTYP) ;
N TEMP
I DSUB=1 S FLIT="Finding: "
I DSUB>1 S FLIT="Add. Finding: "
S FLONG=0
I $L(FLIT_FNAME_" ("_FTYP_")")>60 S FLONG=1
I 'FLONG S FNAME=FLIT_FNAME_" ("_FTYP_")"
I FLONG S FNAME=FLIT_FNAME
S TEMP=$J("",12+$L(SEP))_$E(FNAME,1,60)_$J("",60-$L(FNAME))
S NLINE=NLINE+1
S ^TMP("PXRMDLG",$J,NLINE,0)=TEMP
I FLONG D
.S NLINE=NLINE+1
.S FTAB=$S(DSUB=1:21,1:26)
.S ^TMP("PXRMDLG",$J,NLINE,0)=$J("",FTAB)_"("_FTYP_")"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMDLG3 4347 printed Apr 09, 2024@20:55:09 Page 2
PXRMDLG3 ;SLC/PJH - Reminder Dialog Edit/Inquiry ;03/27/2015 08:40
+1 ;;2.0;CLINICAL REMINDERS;**45**;Feb 04, 2005;Build 566
+2 ;
+3 ;
+4 ;Display national dialog
START NEW NLINE,NSEL
+1 SET NLINE=0
SET NSEL=0
+2 ;
+3 ;Group header
+4 IF $PIECE($GET(^PXRMD(801.41,PXRMDIEN,0)),U,4)="G"
Begin DoDot:1
+5 DO DLINE(PXRMDIEN,"","")
End DoDot:1
+6 ;Other components
+7 DO DETAIL(PXRMDIEN,"")
+8 ;Create headings
+9 DO CHGCAP^VALM("HEADER1","Item Seq.")
+10 DO CHGCAP^VALM("HEADER2","Dialog Details/Findings")
+11 DO CHGCAP^VALM("HEADER3","Type")
+12 SET VALMCNT=NLINE
+13 SET ^TMP("PXRMDLG",$JOB,"VALMCNT")=VALMCNT
EXIT QUIT
+1 ;
+2 ;Additional Findings
+3 ;-------------------
ADD(DIEN) ;
+1 NEW FIND,FSUB,FTYP,FNAME,FNUM
+2 SET FSUB=0
+3 FOR
SET FSUB=$ORDER(^PXRMD(801.41,DIEN,3,FSUB))
if 'FSUB
QUIT
Begin DoDot:1
+4 SET FIND=$PIECE($GET(^PXRMD(801.41,DIEN,3,FSUB,0)),U)
if FIND=""
QUIT
+5 SET FNAME=""
DO FDESC(FIND)
if FNAME=""
QUIT
+6 ;Save additional finding name
+7 SET FOUND=1
DO SAVE(2,FNAME,FTYP)
End DoDot:1
+8 QUIT
+9 ;
+10 ;Build listman global for all components
+11 ;---------------------------------------
DETAIL(PXRMDIEN,LEV) ;
+1 NEW DDATA,DDLG,DEND,DIEN,DNAM,DSEQ,DSTRT,IND,JND,DSUB
+2 SET DSEQ=0
+3 ;
+4 ;Get each sequence number
+5 FOR
SET DSEQ=$ORDER(^PXRMD(801.41,PXRMDIEN,10,"B",DSEQ))
if 'DSEQ
QUIT
Begin DoDot:1
+6 ;Determine subscript
+7 SET DSUB=$ORDER(^PXRMD(801.41,PXRMDIEN,10,"B",DSEQ,""))
if 'DSUB
QUIT
+8 ;Get ien of prompt/component
+9 SET DIEN=$PIECE($GET(^PXRMD(801.41,PXRMDIEN,10,DSUB,0)),U,2)
if 'DIEN
QUIT
+10 ;Ignore prompts and forced values
+11 IF "PF"[$PIECE($GET(^PXRMD(801.41,DIEN,0)),U,4)
QUIT
+12 ;Save line in workfile
+13 DO DLINE(DIEN,LEV,DSEQ)
+14 ;
+15 ;Process any sub-components
+16 DO DETAIL(DIEN,LEV_DSEQ_".")
+17 ;Extra line feed
+18 IF LEV=""
Begin DoDot:2
+19 SET NLINE=NLINE+1
+20 SET ^TMP("PXRMDLG",$JOB,NLINE,0)=$JUSTIFY("",79)
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
+23 ;Save individual component details
+24 ;---------------------------------
DLINE(DIEN,LEV,DSEQ) ;
+1 ;Dialog name
+2 SET DNAM=$PIECE($GET(^PXRMD(801.41,DIEN,0)),U)
if DNAM=""
QUIT
+3 ;Check if standard PXRM prompt
+4 IF $$PXRM^PXRMEXID(DNAM)
QUIT
+5 ;
+6 NEW DPTX,DTXT,DTYP,EXIST,ITEM,TEMP,SEP
+7 SET ITEM=""
+8 SET NSEL=NSEL+1
SET ITEM=NSEL
+9 SET NLINE=NLINE+1
SET SEP=$EXTRACT(LEV,$LENGTH(LEV))
+10 SET TEMP=$JUSTIFY(ITEM,3)_$JUSTIFY("",4)_LEV_DSEQ
+11 ;Determine type
+12 SET DTYP=$SELECT($PIECE($GET(^PXRMD(801.41,DIEN,0)),U,4)="G":"group",1:"element")
+13 ;Dialog component display
+14 IF $LENGTH(TEMP)<13
SET TEMP=TEMP_$JUSTIFY("",12+$LENGTH(SEP)-$LENGTH(TEMP))_$EXTRACT(DNAM,1,50)
+15 IF '$TEST
SET TEMP=TEMP_" "_$EXTRACT(DNAM,1,50)
+16 ;Add Type
+17 SET ^TMP("PXRMDLG",$JOB,NLINE,0)=TEMP_$JUSTIFY("",70-$LENGTH(TEMP))_DTYP
+18 ;
+19 ;Set up selection index
+20 SET ^TMP("PXRMDLG",$JOB,"IDX",NSEL,DIEN)=""
+21 ;
+22 ;Insert finding items
+23 IF ("element;group"[DTYP)
Begin DoDot:1
+24 NEW DSUB,FDATA,FILENUM,FLIT,FLONG,FNAME,FOUND,FREP,FTAB,FTYP,TEMP
+25 ;Findings
+26 SET FNAME=""
SET FOUND=0
+27 DO FDESC($PIECE($GET(^PXRMD(801.41,DIEN,1)),U,5))
+28 IF FNAME'=""
SET FOUND=1
DO SAVE(1,FNAME,FTYP)
+29 ;Additional findings (see ADD^PXRMDLG2)
+30 DO ADD(DIEN)
+31 ;If no findings
+32 IF 'FOUND
Begin DoDot:2
+33 SET NLINE=NLINE+1
+34 SET ^TMP("PXRMDLG",$JOB,NLINE,0)=$JUSTIFY("",12+$LENGTH(SEP))_"Finding: *NONE*"
End DoDot:2
End DoDot:1
+35 QUIT
+36 ;
+37 ;Finding description
+38 ;-------------------
FDESC(FIEN) ;
+1 NEW FGLOB,FITEM
+2 ;Determine finding type
+3 SET FGLOB=$PIECE(FIEN,";",2)
if FGLOB=""
QUIT
+4 SET FITEM=$PIECE(FIEN,";")
if FITEM=""
QUIT
+5 ;Diagnosis POV
+6 IF FGLOB["ICD9"
Begin DoDot:1
+7 SET FTYP="DIAGNOSIS"
SET FGLOB=U_FGLOB_FITEM_",0)"
+8 SET FNAME=$PIECE($GET(@FGLOB),U,3)
End DoDot:1
QUIT
+9 IF FGLOB["WV"
Begin DoDot:1
+10 SET FTYP="WH NOTIFICATION PURPOSE"
SET FGLOB=U_FGLOB_FITEM_",0)"
+11 SET FNAME=$PIECE($GET(@FGLOB),U)
End DoDot:1
QUIT
+12 ;Procedure CPT
+13 IF FGLOB["ICPT"
Begin DoDot:1
+14 SET FTYP="PROCEDURE"
SET FGLOB=U_FGLOB_FITEM_",0)"
+15 SET FNAME=$PIECE($GET(@FGLOB),U,2)
End DoDot:1
QUIT
+16 ;Quick order
+17 IF FGLOB["ORD(101.41"
Begin DoDot:1
+18 SET FTYP="QUICK ORDER"
SET FGLOB=U_FGLOB_FITEM_",0)"
+19 SET FNAME=$PIECE($GET(@FGLOB),U,2)
End DoDot:1
QUIT
+20 IF FGLOB["PXRMD(801.46"
Begin DoDot:1
+21 SET FTYP="GENERAL FINDING"
SET FGLOB=U_FGLOB_FITEM_",0)"
+22 SET FNAME=$PIECE($GET(@FGLOB),U)
End DoDot:1
QUIT
+23 ;Short name for finding type
+24 SET FTYP=$GET(DEF1(FGLOB))
if FTYP=""
QUIT
+25 ;Long name
+26 SET FTYP=$GET(DEF2(FTYP))
+27 SET FGLOB=U_FGLOB_FITEM_",0)"
+28 SET FNAME=$PIECE($GET(@FGLOB),U,1)
+29 IF FNAME=""
SET FNAME=$PIECE($GET(@FGLOB),U)
+30 IF FNAME]""
SET FNAME=FNAME
QUIT
+31 SET FNAME=FITEM
+32 QUIT
+33 ;
+34 ;Save finding details
+35 ;--------------------
SAVE(DSUB,FNAME,FTYP) ;
+1 NEW TEMP
+2 IF DSUB=1
SET FLIT="Finding: "
+3 IF DSUB>1
SET FLIT="Add. Finding: "
+4 SET FLONG=0
+5 IF $LENGTH(FLIT_FNAME_" ("_FTYP_")")>60
SET FLONG=1
+6 IF 'FLONG
SET FNAME=FLIT_FNAME_" ("_FTYP_")"
+7 IF FLONG
SET FNAME=FLIT_FNAME
+8 SET TEMP=$JUSTIFY("",12+$LENGTH(SEP))_$EXTRACT(FNAME,1,60)_$JUSTIFY("",60-$LENGTH(FNAME))
+9 SET NLINE=NLINE+1
+10 SET ^TMP("PXRMDLG",$JOB,NLINE,0)=TEMP
+11 IF FLONG
Begin DoDot:1
+12 SET NLINE=NLINE+1
+13 SET FTAB=$SELECT(DSUB=1:21,1:26)
+14 SET ^TMP("PXRMDLG",$JOB,NLINE,0)=$JUSTIFY("",FTAB)_"("_FTYP_")"
End DoDot:1
+15 QUIT
