Routine: PXRMDLG3

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)

 ;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)

 ;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*"

 ;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

 ;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_")"

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMDLG3   4347     printed  Feb 18, 2025@23:10:17                                                                                                                                                                                                    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

PXRMDLG3.m