IBDFM1 ;ALB/CJM - Compiling bubbles and hand print fields;3/1/93
;;3.0;AUTOMATED INFO COLLECTION SYS;**13,25,38**;APR 24, 1997
;
DRWBBL(ROW,COL,PI,VALUE,FNAME,FID,ALLOWED,DISPLAY,HDR,QLFR,DYN,CNT,SUBHDR,QTY,ND2,SLCTN) ;
;returns "" if no bubble created, else the ien
;
N BUBBLE
S DISPLAY=$E(DISPLAY,1,80),HDR=$E(HDR,1,40)
S DISPLAY=$TR(DISPLAY,"""\","``")
S DYN=+$G(DYN),CNT=+$G(CNT)
;
;don't want to associate a value with the bubble if there is no input interface for the type of data
I 'PI S VALUE=""
;
;compiling blocks?
I IBPRINT("COMPILING_BLOCKS") D CMPBBL Q:'IBPRINT("WRITE_IF_COMPILING")
;
;don't draw a bubble if in the list processor
Q:IBDEVICE("LISTMAN")
;
;add the offsets for the block to position
S ROW=ROW+IBBLK("Y"),COL=COL+IBBLK("X")
;
;might not be creating a FORM DEFINITION TABLE - case of toolkit form
I IBFORM("TOOLKIT") S @IBARRAY("BUBBLES")@(ROW,COL)="" Q
;
;case of FORM DEFINITION TABLE being created - all forms but toolkit
Q:IBFORM("COMPILED")="F" ;something already went wrong
I IBFORM("TYPE") I $D(^IBD(357.95,IBFORM("TYPE"),0))
E S IBFORM("TYPE")=$$NEWTABLE(.IBFORM)
I 'IBFORM("TYPE") D UNCMPL^IBDF19(.IBFORM,1) Q
;
;add the bubble to the table
K DIC,D0,DINUM,DD S DIC="^IBD(357.95,"_IBFORM("TYPE")_",1,",X=ROW,DA(1)=IBFORM("TYPE"),DIC(0)=""
D FILE^DICN K DIC,DIE,DA
S BUBBLE=$S(+Y<0:"",1:+Y)
I 'BUBBLE D UNCMPL^IBDF19(.IBFORM,1) Q
I BUBBLE D
.D INPUT^IBDFU91(PI,.VALUE) I '$D(VALUE) S VALUE=""
.S ^IBD(357.95,IBFORM("TYPE"),1,BUBBLE,0)=ROW_"^"_COL_"^"_PI_"^"_VALUE_"^"_$G(FNAME)_"^"_FID_"^"_ALLOWED_"^"_DISPLAY_"^"_HDR_"^"_QLFR_"^"_DYN_"^"_CNT_"^"_$G(QTY)_"^"_$G(SLCTN)
.I $L($G(SUBHDR)) S ^IBD(357.95,IBFORM("TYPE"),1,BUBBLE,1)=$E(SUBHDR,1,250)
.I $L($G(ND2)) D
..; -- change external format of 2nd & 3rd codes to internal format
..N IBJ,IBVAL F IBJ=3,4 S IBVAL=$P(ND2,"^",IBJ) I IBVAL]"" D INPUT^IBDFU91(PI,.IBVAL) S $P(ND2,"^",IBJ)=$S($D(IBVAL):IBVAL,1:"")
..S ^IBD(357.95,IBFORM("TYPE"),1,BUBBLE,2)=ND2
.K DIK,DA S DIK="^IBD(357.95,"_IBFORM("TYPE")_",1,",DA=BUBBLE,DA(1)=IBFORM("TYPE") D IX1^DIK K DIK,DA
Q
;
NEWTABLE(IBFORM) ;creates a new FORM DEFINITION table
;returns the ien of the table created, "" if not created
N NODE,SUB,CNT
S IBFORM("TYPE")=$$FORMTYPE^IBDF18D(1)
Q:'IBFORM("TYPE")
S NODE=$G(^IBE(357,IBFORM,0))
S $P(^IBD(357.95,IBFORM("TYPE"),0),"^",9,19)=$P(NODE,"^",9,19) ;not all 19 pieces may exist
S $P(^IBD(357.95,IBFORM("TYPE"),0),"^",20,21)=DT_"^"_IBFORM
S $P(^IBE(357,IBFORM,0),"^",13)=IBFORM("TYPE")
S (CNT,SUB)=0 F S SUB=$O(^IBE(357,IBFORM,2,SUB)) Q:'SUB S NODE=$G(^IBE(357,IBFORM,2,SUB,0)) Q:('+NODE)!('$P(NODE,"^",2)) S CNT=CNT+1,^IBD(357.95,IBFORM("TYPE"),3,CNT,0)=+NODE_"^1",^IBD(357.95,IBFORM("TYPE"),3,"B",+NODE,CNT)=""
S $P(^IBD(357.95,IBFORM("TYPE"),3,0),"^",3,4)=CNT_"^"_CNT
Q IBFORM("TYPE")
;
CMPBBL ;save compiled bubbles for the block
S IBWRTCNT("B")=IBWRTCNT("B")+1
S ^IBE(357.1,IBBLK,"B",IBWRTCNT("B"),0)=ROW_"^"_COL_"^"_PI_"^"_VALUE_"^"_FNAME_"^"_FID_"^"_ALLOWED_"^"_DISPLAY_"^"_HDR_"^"_QLFR_"^"_DYN_"^"_CNT_"^"_$G(QTY)_"^"_$G(SLCTN)
I $L($G(SUBHDR)) S ^IBE(357.1,IBBLK,"B",IBWRTCNT("B"),1)=$E(SUBHDR,1,250)
I $L($G(ND2)) S ^IBE(357.1,IBBLK,"B",IBWRTCNT("B"),2)=ND2
Q
;
CMPHAND ;save compiled hand print fields for the block
S IBWRTCNT("H")=IBWRTCNT("H")+1
S ^IBE(357.1,IBBLK,"H",IBWRTCNT("H"),0)=ROW_"^"_COL_"^"_WIDTH_"^"_PI_"^^"_LINES_"^"_FID_"^"_FNAME_"^"_HDR_"^"_QLFR_"^^"_ITEM_"^^"_PRINT_"^"_READ_"^^"_TYPEDATA
Q
;
DRWHAND(ROW,COL,WIDTH,PI,LINES,FID,FNAME,HDR,QLFR,ITEM,PRINT,READ,TYPEDATA) ;creates hand print field
N NODE
S NODE=""
;
S ITEM=$G(ITEM),PRINT=$G(PRINT),READ=$G(READ),TYPEDATA=$G(TYPEDATA)
;returns "" if no hand print field created, else the ien
Q:('$D(ROW))!('$D(COL))
N HANDPRNT
S HDR=$E(HDR,1,40)
;
;compiling blocks?
I IBPRINT("COMPILING_BLOCKS") D CMPHAND Q:'IBPRINT("WRITE_IF_COMPILING")
;
;don't draw hand print field if in the list processor
Q:IBDEVICE("LISTMAN")
;
;add the offsets for the block to position
S ROW=ROW+IBBLK("Y"),COL=COL+IBBLK("X")
;
;might not be creating a FORM DEFINITION TABLE - case of toolkit form
I IBFORM("TOOLKIT") D Q
.N CNT S CNT=+$G(@IBARRAY("HAND_PRINT"))+1
.S @IBARRAY("HAND_PRINT")@(ROW,COL,CNT)=ROW_"^"_COL_"^"_WIDTH_"^"_PI_"^"_FNAME_"^"_LINES_"^^"_FID_"^"_HDR_"^"_QLFR_"^^"_ITEM_"^^"_PRINT_"^"_READ_"^^"_TYPEDATA
;
;case of FORM DEFINITION TABLE being created - all forms but toolkit
Q:IBFORM("COMPILED")="F" ;something already went wrong
I IBFORM("TYPE") I $D(^IBD(357.95,IBFORM("TYPE"),0))
E S IBFORM("TYPE")=$$NEWTABLE(.IBFORM)
;if 'IBFORM("TYPE") want to recompile this next time around
I 'IBFORM("TYPE") D UNCMPL^IBDF19(.IBFORM,1) Q
;
;add the handprint field to the table
K DIC,D0,DINUM,DD S DIC="^IBD(357.95,"_IBFORM("TYPE")_",2,",X=ROW,DA(1)=IBFORM("TYPE"),DIC(0)=""
D FILE^DICN K DIC,DIE,DA
S HANDPRNT=$S(+Y<0:"",1:+Y)
I 'HANDPRNT D UNCMPL^IBDF19(.IBFORM,1) Q
I HANDPRNT D
.S ^IBD(357.95,IBFORM("TYPE"),2,HANDPRNT,0)=ROW_"^"_COL_"^"_WIDTH_"^"_PI_"^"_FNAME_"^"_LINES_"^^"_FID_"^"_HDR_"^"_QLFR_"^^"_ITEM_"^^"_PRINT_"^"_READ_"^^"_TYPEDATA
.K DIK,DA S DIK="^IBD(357.95,"_IBFORM("TYPE")_",2,",DA=HANDPRNT,DA(1)=IBFORM("TYPE") D IX1^DIK K DIK,DA
Q
;
TRACKBBL(FID,COUNT,QLFR,PI,DISPLAY,VALUE) ;
;IBPFID, the id in form tracking, should be defined
;
; -- do not re-file dynamic data if reprint
Q:$G(REPRINT)
;N SUB,NODE
;S NODE=$G(^IBD(357.96,IBPFID,1,0))
;S SUB=$P(NODE,"^",3)
;S SUB=SUB+1,$P(NODE,"^",3,4)=SUB_"^"_SUB
;D INPUT^IBDFU91(PI,.VALUE) I '$D(VALUE) S VALUE=""
;S ^IBD(357.96,IBPFID,1,SUB,0)=COUNT_"^^"_PI_"^"_VALUE_"^^"_FID_"^^"_DISPLAY_"^^"_QLFR
;S ^IBD(357.96,IBPFID,1,0)=NODE
;K DIK,DA S DIK="^IBD(357.96,IBPFID,1,",DA=SUB,DA(1)=IBPFID D IX^DIK K DIK,DA
;
; -- for problem list, move the narrative to one piece for storing
S DISPLAY=$$DISP(DISPLAY)
;
D INPUT^IBDFU91(PI,.VALUE) I '$D(VALUE) S VALUE=""
S X=COUNT
S DLAYGO=357.96
S DIC="^IBD(357.96,IBPFID,1,"
S DIC(0)="L"
S DIC("P")=$P(^DD(357.96,1,0),"^",2)
S DA(1)=IBPFID
S DIC("DR")=".03////^S X=PI;.04////^S X=VALUE;.06////^S X=FID;.08////^S X=$E(DISPLAY,1,80);.1////^S X=QLFR"
K DD,DO D FILE^DICN K DIC,DA,DLAYGO,DD,DO
Q
;
DISP(DIS) ; -- display narrative :: piece
N I,J
S DIS=$E($G(DIS),1,80)
G:DIS="" DISPQ
G:DIS'[" :: " DISPQ
I $P(DIS," :: ",2,99)="" S DIS=$P(DIS," :: ",1) G DISPQ
;
F I=1:1 D Q:$P(DIS," :: ",2,99)=""
. ;
. ; -- sometimes the string contains "nnnnn :: :: :: narrative"
. I $E(DIS,1,4)=" :: " S DIS=$E(DIS,5,80) Q
. ;
. ; -- get rid of leading spaces
. F J=1:1 Q:$E(DIS)'=" " S DIS=$E(DIS,2,80)
. ;
. ; -- get rid of piece one if Numeric code
. I +DIS>0 S DIS=$P(DIS," :: ",2,99) Q
. ;
. ; -- get rid of piece one if alpha numeric (cpt) code
. I +DIS=0,$P(DIS," :: ",1)?1U4N S DIS=$P(DIS," :: ",2,99) Q
. ;
. ; -- get rid of piece one if alpha numeric icd code
. I +DIS=0,$P(DIS," :: ",1)?1U2.3N.1".".2N S DIS=$P(DIS," :: ",2,99) Q
. ;
. ; -- must be text in piece one, use it as text
. I +DIS=0 S DIS=$P(DIS," :: ",1) Q
DISPQ I DIS=" :: " S DIS="Unknown"
Q DIS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFM1 7274 printed Oct 16, 2024@18:53:30 Page 2
IBDFM1 ;ALB/CJM - Compiling bubbles and hand print fields;3/1/93
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**13,25,38**;APR 24, 1997
+2 ;
DRWBBL(ROW,COL,PI,VALUE,FNAME,FID,ALLOWED,DISPLAY,HDR,QLFR,DYN,CNT,SUBHDR,QTY,ND2,SLCTN) ;
+1 ;returns "" if no bubble created, else the ien
+2 ;
+3 NEW BUBBLE
+4 SET DISPLAY=$EXTRACT(DISPLAY,1,80)
SET HDR=$EXTRACT(HDR,1,40)
+5 SET DISPLAY=$TRANSLATE(DISPLAY,"""\","``")
+6 SET DYN=+$GET(DYN)
SET CNT=+$GET(CNT)
+7 ;
+8 ;don't want to associate a value with the bubble if there is no input interface for the type of data
+9 IF 'PI
SET VALUE=""
+10 ;
+11 ;compiling blocks?
+12 IF IBPRINT("COMPILING_BLOCKS")
DO CMPBBL
if 'IBPRINT("WRITE_IF_COMPILING")
QUIT
+13 ;
+14 ;don't draw a bubble if in the list processor
+15 if IBDEVICE("LISTMAN")
QUIT
+16 ;
+17 ;add the offsets for the block to position
+18 SET ROW=ROW+IBBLK("Y")
SET COL=COL+IBBLK("X")
+19 ;
+20 ;might not be creating a FORM DEFINITION TABLE - case of toolkit form
+21 IF IBFORM("TOOLKIT")
SET @IBARRAY("BUBBLES")@(ROW,COL)=""
QUIT
+22 ;
+23 ;case of FORM DEFINITION TABLE being created - all forms but toolkit
+24 ;something already went wrong
if IBFORM("COMPILED")="F"
QUIT
+25 IF IBFORM("TYPE")
IF $DATA(^IBD(357.95,IBFORM("TYPE"),0))
+26 IF '$TEST
SET IBFORM("TYPE")=$$NEWTABLE(.IBFORM)
+27 IF 'IBFORM("TYPE")
DO UNCMPL^IBDF19(.IBFORM,1)
QUIT
+28 ;
+29 ;add the bubble to the table
+30 KILL DIC,D0,DINUM,DD
SET DIC="^IBD(357.95,"_IBFORM("TYPE")_",1,"
SET X=ROW
SET DA(1)=IBFORM("TYPE")
SET DIC(0)=""
+31 DO FILE^DICN
KILL DIC,DIE,DA
+32 SET BUBBLE=$SELECT(+Y<0:"",1:+Y)
+33 IF 'BUBBLE
DO UNCMPL^IBDF19(.IBFORM,1)
QUIT
+34 IF BUBBLE
Begin DoDot:1
+35 DO INPUT^IBDFU91(PI,.VALUE)
IF '$DATA(VALUE)
SET VALUE=""
+36 SET ^IBD(357.95,IBFORM("TYPE"),1,BUBBLE,0)=ROW_"^"_COL_"^"_PI_"^"_VALUE_"^"_$GET(FNAME)_"^"_FID_"^"_ALLOWED_"^"_DISPLAY_"^"_HDR_"^"_QLFR_"^"_DYN_"^"_CNT_"^"_$GET(QTY)_"^"_$GET(SLCTN)
+37 IF $LENGTH($GET(SUBHDR))
SET ^IBD(357.95,IBFORM("TYPE"),1,BUBBLE,1)=$EXTRACT(SUBHDR,1,250)
+38 IF $LENGTH($GET(ND2))
Begin DoDot:2
+39 ; -- change external format of 2nd & 3rd codes to internal format
+40 NEW IBJ,IBVAL
FOR IBJ=3,4
SET IBVAL=$PIECE(ND2,"^",IBJ)
IF IBVAL]""
DO INPUT^IBDFU91(PI,.IBVAL)
SET $PIECE(ND2,"^",IBJ)=$SELECT($DATA(IBVAL):IBVAL,1:"")
+41 SET ^IBD(357.95,IBFORM("TYPE"),1,BUBBLE,2)=ND2
End DoDot:2
+42 KILL DIK,DA
SET DIK="^IBD(357.95,"_IBFORM("TYPE")_",1,"
SET DA=BUBBLE
SET DA(1)=IBFORM("TYPE")
DO IX1^DIK
KILL DIK,DA
End DoDot:1
+43 QUIT
+44 ;
NEWTABLE(IBFORM) ;creates a new FORM DEFINITION table
+1 ;returns the ien of the table created, "" if not created
+2 NEW NODE,SUB,CNT
+3 SET IBFORM("TYPE")=$$FORMTYPE^IBDF18D(1)
+4 if 'IBFORM("TYPE")
QUIT
+5 SET NODE=$GET(^IBE(357,IBFORM,0))
+6 ;not all 19 pieces may exist
SET $PIECE(^IBD(357.95,IBFORM("TYPE"),0),"^",9,19)=$PIECE(NODE,"^",9,19)
+7 SET $PIECE(^IBD(357.95,IBFORM("TYPE"),0),"^",20,21)=DT_"^"_IBFORM
+8 SET $PIECE(^IBE(357,IBFORM,0),"^",13)=IBFORM("TYPE")
+9 SET (CNT,SUB)=0
FOR
SET SUB=$ORDER(^IBE(357,IBFORM,2,SUB))
if 'SUB
QUIT
SET NODE=$GET(^IBE(357,IBFORM,2,SUB,0))
if ('+NODE)!('$PIECE(NODE,"^",2))
QUIT
SET CNT=CNT+1
SET ^IBD(357.95,IBFORM("TYPE"),3,CNT,0)=+NODE_"^1"
SET ^IBD(357.95,IBFORM("TYPE"),3,"B",+NODE,CNT)=""
+10 SET $PIECE(^IBD(357.95,IBFORM("TYPE"),3,0),"^",3,4)=CNT_"^"_CNT
+11 QUIT IBFORM("TYPE")
+12 ;
CMPBBL ;save compiled bubbles for the block
+1 SET IBWRTCNT("B")=IBWRTCNT("B")+1
+2 SET ^IBE(357.1,IBBLK,"B",IBWRTCNT("B"),0)=ROW_"^"_COL_"^"_PI_"^"_VALUE_"^"_FNAME_"^"_FID_"^"_ALLOWED_"^"_DISPLAY_"^"_HDR_"^"_QLFR_"^"_DYN_"^"_CNT_"^"_$GET(QTY)_"^"_$GET(SLCTN)
+3 IF $LENGTH($GET(SUBHDR))
SET ^IBE(357.1,IBBLK,"B",IBWRTCNT("B"),1)=$EXTRACT(SUBHDR,1,250)
+4 IF $LENGTH($GET(ND2))
SET ^IBE(357.1,IBBLK,"B",IBWRTCNT("B"),2)=ND2
+5 QUIT
+6 ;
CMPHAND ;save compiled hand print fields for the block
+1 SET IBWRTCNT("H")=IBWRTCNT("H")+1
+2 SET ^IBE(357.1,IBBLK,"H",IBWRTCNT("H"),0)=ROW_"^"_COL_"^"_WIDTH_"^"_PI_"^^"_LINES_"^"_FID_"^"_FNAME_"^"_HDR_"^"_QLFR_"^^"_ITEM_"^^"_PRINT_"^"_READ_"^^"_TYPEDATA
+3 QUIT
+4 ;
DRWHAND(ROW,COL,WIDTH,PI,LINES,FID,FNAME,HDR,QLFR,ITEM,PRINT,READ,TYPEDATA) ;creates hand print field
+1 NEW NODE
+2 SET NODE=""
+3 ;
+4 SET ITEM=$GET(ITEM)
SET PRINT=$GET(PRINT)
SET READ=$GET(READ)
SET TYPEDATA=$GET(TYPEDATA)
+5 ;returns "" if no hand print field created, else the ien
+6 if ('$DATA(ROW))!('$DATA(COL))
QUIT
+7 NEW HANDPRNT
+8 SET HDR=$EXTRACT(HDR,1,40)
+9 ;
+10 ;compiling blocks?
+11 IF IBPRINT("COMPILING_BLOCKS")
DO CMPHAND
if 'IBPRINT("WRITE_IF_COMPILING")
QUIT
+12 ;
+13 ;don't draw hand print field if in the list processor
+14 if IBDEVICE("LISTMAN")
QUIT
+15 ;
+16 ;add the offsets for the block to position
+17 SET ROW=ROW+IBBLK("Y")
SET COL=COL+IBBLK("X")
+18 ;
+19 ;might not be creating a FORM DEFINITION TABLE - case of toolkit form
+20 IF IBFORM("TOOLKIT")
Begin DoDot:1
+21 NEW CNT
SET CNT=+$GET(@IBARRAY("HAND_PRINT"))+1
+22 SET @IBARRAY("HAND_PRINT")@(ROW,COL,CNT)=ROW_"^"_COL_"^"_WIDTH_"^"_PI_"^"_FNAME_"^"_LINES_"^^"_FID_"^"_HDR_"^"_QLFR_"^^"_ITEM_"^^"_PRINT_"^"_READ_"^^"_TYPEDATA
End DoDot:1
QUIT
+23 ;
+24 ;case of FORM DEFINITION TABLE being created - all forms but toolkit
+25 ;something already went wrong
if IBFORM("COMPILED")="F"
QUIT
+26 IF IBFORM("TYPE")
IF $DATA(^IBD(357.95,IBFORM("TYPE"),0))
+27 IF '$TEST
SET IBFORM("TYPE")=$$NEWTABLE(.IBFORM)
+28 ;if 'IBFORM("TYPE") want to recompile this next time around
+29 IF 'IBFORM("TYPE")
DO UNCMPL^IBDF19(.IBFORM,1)
QUIT
+30 ;
+31 ;add the handprint field to the table
+32 KILL DIC,D0,DINUM,DD
SET DIC="^IBD(357.95,"_IBFORM("TYPE")_",2,"
SET X=ROW
SET DA(1)=IBFORM("TYPE")
SET DIC(0)=""
+33 DO FILE^DICN
KILL DIC,DIE,DA
+34 SET HANDPRNT=$SELECT(+Y<0:"",1:+Y)
+35 IF 'HANDPRNT
DO UNCMPL^IBDF19(.IBFORM,1)
QUIT
+36 IF HANDPRNT
Begin DoDot:1
+37 SET ^IBD(357.95,IBFORM("TYPE"),2,HANDPRNT,0)=ROW_"^"_COL_"^"_WIDTH_"^"_PI_"^"_FNAME_"^"_LINES_"^^"_FID_"^"_HDR_"^"_QLFR_"^^"_ITEM_"^^"_PRINT_"^"_READ_"^^"_TYPEDATA
+38 KILL DIK,DA
SET DIK="^IBD(357.95,"_IBFORM("TYPE")_",2,"
SET DA=HANDPRNT
SET DA(1)=IBFORM("TYPE")
DO IX1^DIK
KILL DIK,DA
End DoDot:1
+39 QUIT
+40 ;
TRACKBBL(FID,COUNT,QLFR,PI,DISPLAY,VALUE) ;
+1 ;IBPFID, the id in form tracking, should be defined
+2 ;
+3 ; -- do not re-file dynamic data if reprint
+4 if $GET(REPRINT)
QUIT
+5 ;N SUB,NODE
+6 ;S NODE=$G(^IBD(357.96,IBPFID,1,0))
+7 ;S SUB=$P(NODE,"^",3)
+8 ;S SUB=SUB+1,$P(NODE,"^",3,4)=SUB_"^"_SUB
+9 ;D INPUT^IBDFU91(PI,.VALUE) I '$D(VALUE) S VALUE=""
+10 ;S ^IBD(357.96,IBPFID,1,SUB,0)=COUNT_"^^"_PI_"^"_VALUE_"^^"_FID_"^^"_DISPLAY_"^^"_QLFR
+11 ;S ^IBD(357.96,IBPFID,1,0)=NODE
+12 ;K DIK,DA S DIK="^IBD(357.96,IBPFID,1,",DA=SUB,DA(1)=IBPFID D IX^DIK K DIK,DA
+13 ;
+14 ; -- for problem list, move the narrative to one piece for storing
+15 SET DISPLAY=$$DISP(DISPLAY)
+16 ;
+17 DO INPUT^IBDFU91(PI,.VALUE)
IF '$DATA(VALUE)
SET VALUE=""
+18 SET X=COUNT
+19 SET DLAYGO=357.96
+20 SET DIC="^IBD(357.96,IBPFID,1,"
+21 SET DIC(0)="L"
+22 SET DIC("P")=$PIECE(^DD(357.96,1,0),"^",2)
+23 SET DA(1)=IBPFID
+24 SET DIC("DR")=".03////^S X=PI;.04////^S X=VALUE;.06////^S X=FID;.08////^S X=$E(DISPLAY,1,80);.1////^S X=QLFR"
+25 KILL DD,DO
DO FILE^DICN
KILL DIC,DA,DLAYGO,DD,DO
+26 QUIT
+27 ;
DISP(DIS) ; -- display narrative :: piece
+1 NEW I,J
+2 SET DIS=$EXTRACT($GET(DIS),1,80)
+3 if DIS=""
GOTO DISPQ
+4 if DIS'["
GOTO DISPQ
+5 IF $PIECE(DIS," :: ",2,99)=""
SET DIS=$PIECE(DIS," :: ",1)
GOTO DISPQ
+6 ;
+7 FOR I=1:1
Begin DoDot:1
+8 ;
+9 ; -- sometimes the string contains "nnnnn :: :: :: narrative"
+10 IF $EXTRACT(DIS,1,4)=" :: "
SET DIS=$EXTRACT(DIS,5,80)
QUIT
+11 ;
+12 ; -- get rid of leading spaces
+13 FOR J=1:1
if $EXTRACT(DIS)'=" "
QUIT
SET DIS=$EXTRACT(DIS,2,80)
+14 ;
+15 ; -- get rid of piece one if Numeric code
+16 IF +DIS>0
SET DIS=$PIECE(DIS," :: ",2,99)
QUIT
+17 ;
+18 ; -- get rid of piece one if alpha numeric (cpt) code
+19 IF +DIS=0
IF $PIECE(DIS," :: ",1)?1U4N
SET DIS=$PIECE(DIS," :: ",2,99)
QUIT
+20 ;
+21 ; -- get rid of piece one if alpha numeric icd code
+22 IF +DIS=0
IF $PIECE(DIS," :: ",1)?1U2.3N.1".".2N
SET DIS=$PIECE(DIS," :: ",2,99)
QUIT
+23 ;
+24 ; -- must be text in piece one, use it as text
+25 IF +DIS=0
SET DIS=$PIECE(DIS," :: ",1)
QUIT
End DoDot:1
if $PIECE(DIS,"
QUIT
DISPQ IF DIS=" :: "
SET DIS="Unknown"
+1 QUIT DIS
