Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDFM1

IBDFM1.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. 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
  1. ;
  1. N BUBBLE
  1. S DISPLAY=$E(DISPLAY,1,80),HDR=$E(HDR,1,40)
  1. S DISPLAY=$TR(DISPLAY,"""\","``")
  1. S DYN=+$G(DYN),CNT=+$G(CNT)
  1. ;
  1. ;don't want to associate a value with the bubble if there is no input interface for the type of data
  1. I 'PI S VALUE=""
  1. ;
  1. ;compiling blocks?
  1. I IBPRINT("COMPILING_BLOCKS") D CMPBBL Q:'IBPRINT("WRITE_IF_COMPILING")
  1. ;
  1. ;don't draw a bubble if in the list processor
  1. Q:IBDEVICE("LISTMAN")
  1. ;
  1. ;add the offsets for the block to position
  1. S ROW=ROW+IBBLK("Y"),COL=COL+IBBLK("X")
  1. ;
  1. ;might not be creating a FORM DEFINITION TABLE - case of toolkit form
  1. I IBFORM("TOOLKIT") S @IBARRAY("BUBBLES")@(ROW,COL)="" Q
  1. ;
  1. ;case of FORM DEFINITION TABLE being created - all forms but toolkit
  1. Q:IBFORM("COMPILED")="F" ;something already went wrong
  1. I IBFORM("TYPE") I $D(^IBD(357.95,IBFORM("TYPE"),0))
  1. E S IBFORM("TYPE")=$$NEWTABLE(.IBFORM)
  1. I 'IBFORM("TYPE") D UNCMPL^IBDF19(.IBFORM,1) Q
  1. ;
  1. ;add the bubble to the table
  1. K DIC,D0,DINUM,DD S DIC="^IBD(357.95,"_IBFORM("TYPE")_",1,",X=ROW,DA(1)=IBFORM("TYPE"),DIC(0)=""
  1. D FILE^DICN K DIC,DIE,DA
  1. S BUBBLE=$S(+Y<0:"",1:+Y)
  1. I 'BUBBLE D UNCMPL^IBDF19(.IBFORM,1) Q
  1. I BUBBLE D
  1. .D INPUT^IBDFU91(PI,.VALUE) I '$D(VALUE) S VALUE=""
  1. .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)
  1. .I $L($G(SUBHDR)) S ^IBD(357.95,IBFORM("TYPE"),1,BUBBLE,1)=$E(SUBHDR,1,250)
  1. .I $L($G(ND2)) D
  1. ..; -- change external format of 2nd & 3rd codes to internal format
  1. ..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:"")
  1. ..S ^IBD(357.95,IBFORM("TYPE"),1,BUBBLE,2)=ND2
  1. .K DIK,DA S DIK="^IBD(357.95,"_IBFORM("TYPE")_",1,",DA=BUBBLE,DA(1)=IBFORM("TYPE") D IX1^DIK K DIK,DA
  1. Q
  1. ;
  1. NEWTABLE(IBFORM) ;creates a new FORM DEFINITION table
  1. ;returns the ien of the table created, "" if not created
  1. N NODE,SUB,CNT
  1. S IBFORM("TYPE")=$$FORMTYPE^IBDF18D(1)
  1. Q:'IBFORM("TYPE")
  1. S NODE=$G(^IBE(357,IBFORM,0))
  1. S $P(^IBD(357.95,IBFORM("TYPE"),0),"^",9,19)=$P(NODE,"^",9,19) ;not all 19 pieces may exist
  1. S $P(^IBD(357.95,IBFORM("TYPE"),0),"^",20,21)=DT_"^"_IBFORM
  1. S $P(^IBE(357,IBFORM,0),"^",13)=IBFORM("TYPE")
  1. 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)=""
  1. S $P(^IBD(357.95,IBFORM("TYPE"),3,0),"^",3,4)=CNT_"^"_CNT
  1. Q IBFORM("TYPE")
  1. ;
  1. CMPBBL ;save compiled bubbles for the block
  1. S IBWRTCNT("B")=IBWRTCNT("B")+1
  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)
  1. I $L($G(SUBHDR)) S ^IBE(357.1,IBBLK,"B",IBWRTCNT("B"),1)=$E(SUBHDR,1,250)
  1. I $L($G(ND2)) S ^IBE(357.1,IBBLK,"B",IBWRTCNT("B"),2)=ND2
  1. Q
  1. ;
  1. CMPHAND ;save compiled hand print fields for the block
  1. S IBWRTCNT("H")=IBWRTCNT("H")+1
  1. S ^IBE(357.1,IBBLK,"H",IBWRTCNT("H"),0)=ROW_"^"_COL_"^"_WIDTH_"^"_PI_"^^"_LINES_"^"_FID_"^"_FNAME_"^"_HDR_"^"_QLFR_"^^"_ITEM_"^^"_PRINT_"^"_READ_"^^"_TYPEDATA
  1. Q
  1. ;
  1. DRWHAND(ROW,COL,WIDTH,PI,LINES,FID,FNAME,HDR,QLFR,ITEM,PRINT,READ,TYPEDATA) ;creates hand print field
  1. N NODE
  1. S NODE=""
  1. ;
  1. S ITEM=$G(ITEM),PRINT=$G(PRINT),READ=$G(READ),TYPEDATA=$G(TYPEDATA)
  1. ;returns "" if no hand print field created, else the ien
  1. Q:('$D(ROW))!('$D(COL))
  1. N HANDPRNT
  1. S HDR=$E(HDR,1,40)
  1. ;
  1. ;compiling blocks?
  1. I IBPRINT("COMPILING_BLOCKS") D CMPHAND Q:'IBPRINT("WRITE_IF_COMPILING")
  1. ;
  1. ;don't draw hand print field if in the list processor
  1. Q:IBDEVICE("LISTMAN")
  1. ;
  1. ;add the offsets for the block to position
  1. S ROW=ROW+IBBLK("Y"),COL=COL+IBBLK("X")
  1. ;
  1. ;might not be creating a FORM DEFINITION TABLE - case of toolkit form
  1. I IBFORM("TOOLKIT") D Q
  1. .N CNT S CNT=+$G(@IBARRAY("HAND_PRINT"))+1
  1. .S @IBARRAY("HAND_PRINT")@(ROW,COL,CNT)=ROW_"^"_COL_"^"_WIDTH_"^"_PI_"^"_FNAME_"^"_LINES_"^^"_FID_"^"_HDR_"^"_QLFR_"^^"_ITEM_"^^"_PRINT_"^"_READ_"^^"_TYPEDATA
  1. ;
  1. ;case of FORM DEFINITION TABLE being created - all forms but toolkit
  1. Q:IBFORM("COMPILED")="F" ;something already went wrong
  1. I IBFORM("TYPE") I $D(^IBD(357.95,IBFORM("TYPE"),0))
  1. E S IBFORM("TYPE")=$$NEWTABLE(.IBFORM)
  1. ;if 'IBFORM("TYPE") want to recompile this next time around
  1. I 'IBFORM("TYPE") D UNCMPL^IBDF19(.IBFORM,1) Q
  1. ;
  1. ;add the handprint field to the table
  1. K DIC,D0,DINUM,DD S DIC="^IBD(357.95,"_IBFORM("TYPE")_",2,",X=ROW,DA(1)=IBFORM("TYPE"),DIC(0)=""
  1. D FILE^DICN K DIC,DIE,DA
  1. S HANDPRNT=$S(+Y<0:"",1:+Y)
  1. I 'HANDPRNT D UNCMPL^IBDF19(.IBFORM,1) Q
  1. I HANDPRNT D
  1. .S ^IBD(357.95,IBFORM("TYPE"),2,HANDPRNT,0)=ROW_"^"_COL_"^"_WIDTH_"^"_PI_"^"_FNAME_"^"_LINES_"^^"_FID_"^"_HDR_"^"_QLFR_"^^"_ITEM_"^^"_PRINT_"^"_READ_"^^"_TYPEDATA
  1. .K DIK,DA S DIK="^IBD(357.95,"_IBFORM("TYPE")_",2,",DA=HANDPRNT,DA(1)=IBFORM("TYPE") D IX1^DIK K DIK,DA
  1. Q
  1. ;
  1. TRACKBBL(FID,COUNT,QLFR,PI,DISPLAY,VALUE) ;
  1. ;IBPFID, the id in form tracking, should be defined
  1. ;
  1. ; -- do not re-file dynamic data if reprint
  1. Q:$G(REPRINT)
  1. ;N SUB,NODE
  1. ;S NODE=$G(^IBD(357.96,IBPFID,1,0))
  1. ;S SUB=$P(NODE,"^",3)
  1. ;S SUB=SUB+1,$P(NODE,"^",3,4)=SUB_"^"_SUB
  1. ;D INPUT^IBDFU91(PI,.VALUE) I '$D(VALUE) S VALUE=""
  1. ;S ^IBD(357.96,IBPFID,1,SUB,0)=COUNT_"^^"_PI_"^"_VALUE_"^^"_FID_"^^"_DISPLAY_"^^"_QLFR
  1. ;S ^IBD(357.96,IBPFID,1,0)=NODE
  1. ;K DIK,DA S DIK="^IBD(357.96,IBPFID,1,",DA=SUB,DA(1)=IBPFID D IX^DIK K DIK,DA
  1. ;
  1. ; -- for problem list, move the narrative to one piece for storing
  1. S DISPLAY=$$DISP(DISPLAY)
  1. ;
  1. D INPUT^IBDFU91(PI,.VALUE) I '$D(VALUE) S VALUE=""
  1. S X=COUNT
  1. S DLAYGO=357.96
  1. S DIC="^IBD(357.96,IBPFID,1,"
  1. S DIC(0)="L"
  1. S DIC("P")=$P(^DD(357.96,1,0),"^",2)
  1. S DA(1)=IBPFID
  1. 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"
  1. K DD,DO D FILE^DICN K DIC,DA,DLAYGO,DD,DO
  1. Q
  1. ;
  1. DISP(DIS) ; -- display narrative :: piece
  1. N I,J
  1. S DIS=$E($G(DIS),1,80)
  1. G:DIS="" DISPQ
  1. G:DIS'[" :: " DISPQ
  1. I $P(DIS," :: ",2,99)="" S DIS=$P(DIS," :: ",1) G DISPQ
  1. ;
  1. F I=1:1 D Q:$P(DIS," :: ",2,99)=""
  1. . ;
  1. . ; -- sometimes the string contains "nnnnn :: :: :: narrative"
  1. . I $E(DIS,1,4)=" :: " S DIS=$E(DIS,5,80) Q
  1. . ;
  1. . ; -- get rid of leading spaces
  1. . F J=1:1 Q:$E(DIS)'=" " S DIS=$E(DIS,2,80)
  1. . ;
  1. . ; -- get rid of piece one if Numeric code
  1. . I +DIS>0 S DIS=$P(DIS," :: ",2,99) Q
  1. . ;
  1. . ; -- get rid of piece one if alpha numeric (cpt) code
  1. . I +DIS=0,$P(DIS," :: ",1)?1U4N S DIS=$P(DIS," :: ",2,99) Q
  1. . ;
  1. . ; -- get rid of piece one if alpha numeric icd code
  1. . I +DIS=0,$P(DIS," :: ",1)?1U2.3N.1".".2N S DIS=$P(DIS," :: ",2,99) Q
  1. . ;
  1. . ; -- must be text in piece one, use it as text
  1. . I +DIS=0 S DIS=$P(DIS," :: ",1) Q
  1. DISPQ I DIS=" :: " S DIS="Unknown"
  1. Q DIS