- 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 Jan 18, 2025@03:53:56 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