IBDFBKS3 ;ALB/CJM/AAS - ENCOUNTER FORM - create form spec for scanning (Broker Version) ; 6-JUN-95 [ 11/13/96 3:32 PM ]
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
BUBBLE ;
N COUNT
;
D PRINTEND ;the end program for the prior field
;
D BLDARY^IBDFBKS("FIELD ' "_FIELD)
;
;** NAME **
D BLDARY^IBDFBKS(" NAME = """_NAME_""";")
;
;** ELEMTYPE **
D BLDARY^IBDFBKS(" ELEMTYPE = RECT;")
;
;** METRIC **
D BLDARY^IBDFBKS(" METRIC = 30 16 0 0 -16 -12 "_$G(IBDFILL,20)_" "_$G(IBDBKGND,5)_" 1;")
;D BLDARY^IBDFBKS(" METRIC = 30 16 0 0 -16 -12 20 5 1;")
;
;** DATATYPE **
D BLDARY^IBDFBKS(" DATATYPE =INT;")
;
;** LENGTH **
I (TYPE=1)!(TYPE=2) D
.D BLDARY^IBDFBKS(" LENGTH = ")
.S COUNT=0
.S COL="" F S COL=$O(@SCAN@(PAGE,FID,TYPE,COL)) Q:COL="" S ROW="" F S ROW=$O(@SCAN@(PAGE,FID,TYPE,COL,ROW)) Q:ROW="" S COUNT=COUNT+1
.S IBDFSA(IBLC)=IBDFSA(IBLC)_COUNT_";"
I (TYPE=0)!(TYPE=3) D BLDARY^IBDFBKS(" LENGTH = 1;")
;
;** POINTS **
I (TYPE=0)!(TYPE=3) S Y=ROW,X=COL D FINDBUB(.Y,.X) D BLDARY^IBDFBKS(" POINTS = "_Y_" "_X_";")
I (TYPE=1)!(TYPE=2) D
.D BLDARY^IBDFBKS(" POINTS =")
.S COL="" F S COL=$O(@SCAN@(PAGE,FID,TYPE,COL)) Q:COL="" D
..S ROW="" F S ROW=$O(@SCAN@(PAGE,FID,TYPE,COL,ROW)) Q:ROW="" D
...S X=COL,Y=ROW
...D FINDBUB(.Y,.X)
...I $L(IBDFSA(IBLC))+$L(" "_Y_" "_X)<252 S IBDFSA(IBLC)=IBDFSA(IBLC)_" "_Y_" "_X Q
...D BLDARY^IBDFBKS("~~~"_" "_Y_" "_X)
.S IBDFSA(IBLC)=IBDFSA(IBLC)_";"
;
;** PAGE **
D BLDARY^IBDFBKS(" PAGE = "_PAGE_";")
;
;** END ** program to enforce selection rule and to go to end of page
I TYPE=1 D ;exactly one required
.D ADDTOEND(" if (GETSTATUS("_FIELD_") == FIELD_BLANK){")
.;D ADDTOEND(" \' SHOW(\"""_$$CKNAM(NAME)_" is required!\"");")
.D ADDTOEND(" if (BATCH==0) {FIELDSTATUS = FIELD_BAD;}")
.D ADDTOEND(" if (BATCH==1) {saveunrf = "_FIELD_";}")
.D ADDTOEND(" }")
.D ADDTOEND(" if ((GETSTATUS("_FIELD_") == FIELD_TOOMANY)&&(BATCH == 1)) {")
.D ADDTOEND(" saveunrf = "_FIELD_";}")
;
I TYPE=2 D ;at most one required
.D ADDTOEND(" if ((GETSTATUS("_FIELD_") == FIELD_TOOMANY)&&(BATCH == 1)) {")
.D ADDTOEND(" saveunrf = "_FIELD_";}")
;
I TYPE=3,LAST'="" D ;at least one required
.D ADDTOEND(" INT field;")
.D ADDTOEND(" field="_FIRST_";") ;AAS Changed 11/14
.N X S X=LAST+1 D ADDTOEND(" while (field<"_X_"){") ;AAS changed 11/14
.D ADDTOEND(" if (GETSTATUS(field) != FIELD_BLANK) break;")
.D ADDTOEND(" field=field+1;")
.D ADDTOEND(" }")
.S X=LAST+1 D ADDTOEND(" if (field == "_X_"){")
.D ADDTOEND(" SHOW(\"""_$$CKNAM(OLDNAME)_" at least 1 required!\"");")
.D ADDTOEND(" FIELDSTATUS = FIELD_BAD;")
.D ADDTOEND(" }")
;D ADDTOEND(" };")
;
;** XMAP **
; -- only TYPE=0 (selection rule=anynumber) might be dynmaic
I (TYPE=0)!(TYPE=3) D BLDARY^IBDFBKS(" XMAP = "","_$S($P(NODE,"^",9):"D:"_FID_":"_$P(NODE,"^",10),1:"B:"_IEN_":"_$$GETCODE($P(NODE,"^",2),$P(NODE,"^")))_""";")
;
I (TYPE=1)!(TYPE=2) D
.D BLDARY^IBDFBKS(" XMAP = """)
.S COL=""
.F S COL=$O(@SCAN@(PAGE,FID,TYPE,COL)) Q:COL="" D
..S ROW="" F S ROW=$O(@SCAN@(PAGE,FID,TYPE,COL,ROW)) Q:ROW="" D
...S IEN=$O(@SCAN@(PAGE,FID,TYPE,COL,ROW,0)) I IEN D
....S NODE=$G(^(IEN))
....N IBX
....S IBX=","_$S($P(NODE,"^",9):"D:"_FID_":"_$P(NODE,"^",10),1:"B:"_IEN_":"_$$GETCODE($P(NODE,"^",2),$P(NODE,"^")))
....I $L(IBDFSA(IBLC))+$L(IBX)<252 S IBDFSA(IBLC)=IBDFSA(IBLC)_IBX Q
....D BLDARY^IBDFBKS("~~~"_IBX)
.S IBDFSA(IBLC)=IBDFSA(IBLC)_""";"
;
;** MAP **
I (TYPE=0)!(TYPE=3) D BLDARY^IBDFBKS(" MAP = "" ,"_$TR($P(NODE,"^",6),",;"," ")_""";")
;
I (TYPE=1)!(TYPE=2) D
.D BLDARY^IBDFBKS(" MAP = "" ")
.;
.S COL="" F S COL=$O(@SCAN@(PAGE,FID,TYPE,COL)) Q:COL="" S ROW="" F S ROW=$O(@SCAN@(PAGE,FID,TYPE,COL,ROW)) Q:ROW="" S IEN=$O(@SCAN@(PAGE,FID,TYPE,COL,ROW,0)) D
..I IEN S NODE=$G(@SCAN@(PAGE,FID,TYPE,COL,ROW,IEN))
..I $L(IBDFSA(IBLC))+$L($TR($P(NODE,"^",6),",;"," "))<252 S IBDFSA(IBLC)=IBDFSA(IBLC)_","_$TR($P(NODE,"^",6),",;"," ") Q
..D BLDARY^IBDFBKS("~~~"_","_$TR($P(NODE,"^",6),",;"," "))
.S IBDFSA(IBLC)=IBDFSA(IBLC)_""";"
I $D(OTHER($P(FID,"("),IEN)) S OTHER($P(FID,"("),IEN)=FIELD
Q
;
FINDBUB(Y,X) ;
;converts row,col of bubble to paperkeyboard points, with proper offsets added - call by reference
S X=((COL*COLWIDTH)+(XBUBOS+XOFFSET))*CONVERT
;S X=1+$FN(X,"",0)
S X=$FN(X,"",0)
S Y=((ROW*ROWHT)+(YOFFSET+YBUBOS))*CONVERT
;S Y=1+$FN(Y,"",0)
S Y=$FN(Y,"",0)
Q
;
ADDTOBEG(TEXT) ;
I '$D(BEGIN) S BEGIN(1)=" BEGIN = {",BLN=1
S BLN=BLN+1
S BEGIN(BLN)=TEXT
Q
;
PRINTBEG ;
I $D(BEGIN) D
.S BLN=0 F S BLN=$O(BEGIN(BLN)) Q:'BLN D BLDARY^IBDFBKS(BEGIN(BLN))
.D BLDARY^IBDFBKS(" };")
.K BEGIN
Q
;
ADDTOEND(TEXT) ;
I '$D(END) S END(1)=" END = {",LN=1
S LN=LN+1
S END(LN)=TEXT
Q
;
PRINTEND ;
I $D(END) D
.S LN=0 F S LN=$O(END(LN)) Q:'LN D BLDARY^IBDFBKS(END(LN))
.D BLDARY^IBDFBKS(" };")
.K END
I PRIORPG'=PAGE D PAGEEND(PRIORPG)
I PAGE>1,PRIORPG'=PAGE D PAGETOP(PAGE)
S PRIORPG=PAGE
Q
;
GETCODE(VALUE,PI) ;returns the value after passing it through the output transform contained in the package interface file
;
N X,Y S (Y,X)=VALUE
;
I PI X $G(^IBE(357.6,PI,14))
Q Y
;
PAGEEND(PAGE) ;end of page processing
N FLD
S FIELD=FIELD+1
F COUNT=1:1 S LINE=$T(BOTTOM+COUNT^IBDFBKS1),TAG=$P(LINE,";;"),LINE=$P(LINE,";;",2) Q:TAG["QUIT" D
.I TAG["NUMBER" D BLDARY^IBDFBKS("FIELD ' "_FIELD) Q
.I TAG["NAME" D BLDARY^IBDFBKS(" NAME = ""BOTTOM OF PAGE"_PAGE_""";") Q
.I TAG["PAGE" D BLDARY^IBDFBKS(" PAGE = "_PAGE_";") Q
.I TAG["SAVE" D Q
..D BLDARY^IBDFBKS(" Save = STRCAT(\""SAVEFORM(\"",ITOA(GETIVALUE(7)));")
..D BLDARY^IBDFBKS(" Save = STRCAT(Save,"","_PAGE_",,V)"");")
..;
.I TAG["EXPORT" D Q
..D BLDARY^IBDFBKS(" DDEEXEC(ddechan,\""$$NEW$$("");")
..D BLDARY^IBDFBKS(" Data=\""$$ADD$$(FORMTYPE="_IBFORMID_",\"";")
..D BLDARY^IBDFBKS(" DDEEXEC(ddechan,Data);")
..D BLDARY^IBDFBKS(" Data=STRCAT(\""$$ADD$$(FORMID=\"",ITOA(GETIVALUE(7)));")
..D BLDARY^IBDFBKS(" Data=STRCAT(Data,\"",\"");")
..D BLDARY^IBDFBKS(" DDEEXEC(ddechan,Data);")
..D BLDARY^IBDFBKS(" Data=\""$$ADD$$(PAGE="_PAGE_",\"";")
..D BLDARY^IBDFBKS(" DDEEXEC(ddechan,Data);")
..D BLDARY^IBDFBKS(" Data=\""$$ADD$$(DATA=,\"";")
..D BLDARY^IBDFBKS(" DDEEXEC(ddechan,Data);")
..;
..D FIELDS^IBDFBKS4
.D BLDARY^IBDFBKS(LINE)
Q
;
;;;.I TAG["EXPORT" D Q
;;;D BLDARY^IBDFBKS(" Data=STRCAT(\""FORMTYPE="_IBFORMID_"\"",RS);")
;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,\""FORMID=\"");")
;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,ITOA(GETIVALUE(7)));")
;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,RS);")
;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,\""PAGE="_PAGE_"\"");")
;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,RS);")
;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,\""DATA=\"");")
;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,RS);")
;;;..D BLDARY^IBDFBKS(" DDEEXEC(ddechan,Data);")
;
PAGETOP(PAGE) ;add field for top of page
S FIELD=FIELD+1
F COUNT=1:1 S LINE=$T(TOPOFPG+COUNT^IBDFBKS1),TAG=$P(LINE,";;"),LINE=$P(LINE,";;",2) Q:TAG["QUIT" D
.I TAG["NUMBER" D BLDARY^IBDFBKS("FIELD ' "_FIELD) Q
.I TAG["FLDNAME" D BLDARY^IBDFBKS(" NAME = ""TOP OF PAGE "_PAGE_""";") Q
.I TAG["PAGE" D BLDARY^IBDFBKS(" PAGE = "_PAGE_";") Q
.D BLDARY^IBDFBKS(LINE)
Q
CKNAM(NAME) ; - format name with \ for paperkey when displaying name
F CHAR="\","'" I NAME[CHAR D
.F A=1:1:$L(NAME,CHAR)-1 S NAME=$P(NAME,CHAR,1,A)_"\"_CHAR_$P(NAME,CHAR,A+1,$L(NAME,CHAR))
Q NAME
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFBKS3 7666 printed Oct 16, 2024@18:52:42 Page 2
IBDFBKS3 ;ALB/CJM/AAS - ENCOUNTER FORM - create form spec for scanning (Broker Version) ; 6-JUN-95 [ 11/13/96 3:32 PM ]
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
BUBBLE ;
+1 NEW COUNT
+2 ;
+3 ;the end program for the prior field
DO PRINTEND
+4 ;
+5 DO BLDARY^IBDFBKS("FIELD ' "_FIELD)
+6 ;
+7 ;** NAME **
+8 DO BLDARY^IBDFBKS(" NAME = """_NAME_""";")
+9 ;
+10 ;** ELEMTYPE **
+11 DO BLDARY^IBDFBKS(" ELEMTYPE = RECT;")
+12 ;
+13 ;** METRIC **
+14 DO BLDARY^IBDFBKS(" METRIC = 30 16 0 0 -16 -12 "_$GET(IBDFILL,20)_" "_$GET(IBDBKGND,5)_" 1;")
+15 ;D BLDARY^IBDFBKS(" METRIC = 30 16 0 0 -16 -12 20 5 1;")
+16 ;
+17 ;** DATATYPE **
+18 DO BLDARY^IBDFBKS(" DATATYPE =INT;")
+19 ;
+20 ;** LENGTH **
+21 IF (TYPE=1)!(TYPE=2)
Begin DoDot:1
+22 DO BLDARY^IBDFBKS(" LENGTH = ")
+23 SET COUNT=0
+24 SET COL=""
FOR
SET COL=$ORDER(@SCAN@(PAGE,FID,TYPE,COL))
if COL=""
QUIT
SET ROW=""
FOR
SET ROW=$ORDER(@SCAN@(PAGE,FID,TYPE,COL,ROW))
if ROW=""
QUIT
SET COUNT=COUNT+1
+25 SET IBDFSA(IBLC)=IBDFSA(IBLC)_COUNT_";"
End DoDot:1
+26 IF (TYPE=0)!(TYPE=3)
DO BLDARY^IBDFBKS(" LENGTH = 1;")
+27 ;
+28 ;** POINTS **
+29 IF (TYPE=0)!(TYPE=3)
SET Y=ROW
SET X=COL
DO FINDBUB(.Y,.X)
DO BLDARY^IBDFBKS(" POINTS = "_Y_" "_X_";")
+30 IF (TYPE=1)!(TYPE=2)
Begin DoDot:1
+31 DO BLDARY^IBDFBKS(" POINTS =")
+32 SET COL=""
FOR
SET COL=$ORDER(@SCAN@(PAGE,FID,TYPE,COL))
if COL=""
QUIT
Begin DoDot:2
+33 SET ROW=""
FOR
SET ROW=$ORDER(@SCAN@(PAGE,FID,TYPE,COL,ROW))
if ROW=""
QUIT
Begin DoDot:3
+34 SET X=COL
SET Y=ROW
+35 DO FINDBUB(.Y,.X)
+36 IF $LENGTH(IBDFSA(IBLC))+$LENGTH(" "_Y_" "_X)<252
SET IBDFSA(IBLC)=IBDFSA(IBLC)_" "_Y_" "_X
QUIT
+37 DO BLDARY^IBDFBKS("~~~"_" "_Y_" "_X)
End DoDot:3
End DoDot:2
+38 SET IBDFSA(IBLC)=IBDFSA(IBLC)_";"
End DoDot:1
+39 ;
+40 ;** PAGE **
+41 DO BLDARY^IBDFBKS(" PAGE = "_PAGE_";")
+42 ;
+43 ;** END ** program to enforce selection rule and to go to end of page
+44 ;exactly one required
IF TYPE=1
Begin DoDot:1
+45 DO ADDTOEND(" if (GETSTATUS("_FIELD_") == FIELD_BLANK){")
+46 ;D ADDTOEND(" \' SHOW(\"""_$$CKNAM(NAME)_" is required!\"");")
+47 DO ADDTOEND(" if (BATCH==0) {FIELDSTATUS = FIELD_BAD;}")
+48 DO ADDTOEND(" if (BATCH==1) {saveunrf = "_FIELD_";}")
+49 DO ADDTOEND(" }")
+50 DO ADDTOEND(" if ((GETSTATUS("_FIELD_") == FIELD_TOOMANY)&&(BATCH == 1)) {")
+51 DO ADDTOEND(" saveunrf = "_FIELD_";}")
End DoDot:1
+52 ;
+53 ;at most one required
IF TYPE=2
Begin DoDot:1
+54 DO ADDTOEND(" if ((GETSTATUS("_FIELD_") == FIELD_TOOMANY)&&(BATCH == 1)) {")
+55 DO ADDTOEND(" saveunrf = "_FIELD_";}")
End DoDot:1
+56 ;
+57 ;at least one required
IF TYPE=3
IF LAST'=""
Begin DoDot:1
+58 DO ADDTOEND(" INT field;")
+59 ;AAS Changed 11/14
DO ADDTOEND(" field="_FIRST_";")
+60 ;AAS changed 11/14
NEW X
SET X=LAST+1
DO ADDTOEND(" while (field<"_X_"){")
+61 DO ADDTOEND(" if (GETSTATUS(field) != FIELD_BLANK) break;")
+62 DO ADDTOEND(" field=field+1;")
+63 DO ADDTOEND(" }")
+64 SET X=LAST+1
DO ADDTOEND(" if (field == "_X_"){")
+65 DO ADDTOEND(" SHOW(\"""_$$CKNAM(OLDNAME)_" at least 1 required!\"");")
+66 DO ADDTOEND(" FIELDSTATUS = FIELD_BAD;")
+67 DO ADDTOEND(" }")
End DoDot:1
+68 ;D ADDTOEND(" };")
+69 ;
+70 ;** XMAP **
+71 ; -- only TYPE=0 (selection rule=anynumber) might be dynmaic
+72 IF (TYPE=0)!(TYPE=3)
DO BLDARY^IBDFBKS(" XMAP = "","_$SELECT($PIECE(NODE,"^",9):"D:"_FID_":"_$PIECE(NODE,"^",10),1:"B:"_IEN_":"_$$GETCODE($PIECE(NODE,"^",2),$PIECE(NODE,"^")))_""";")
+73 ;
+74 IF (TYPE=1)!(TYPE=2)
Begin DoDot:1
+75 DO BLDARY^IBDFBKS(" XMAP = """)
+76 SET COL=""
+77 FOR
SET COL=$ORDER(@SCAN@(PAGE,FID,TYPE,COL))
if COL=""
QUIT
Begin DoDot:2
+78 SET ROW=""
FOR
SET ROW=$ORDER(@SCAN@(PAGE,FID,TYPE,COL,ROW))
if ROW=""
QUIT
Begin DoDot:3
+79 SET IEN=$ORDER(@SCAN@(PAGE,FID,TYPE,COL,ROW,0))
IF IEN
Begin DoDot:4
+80 SET NODE=$GET(^(IEN))
+81 NEW IBX
+82 SET IBX=","_$SELECT($PIECE(NODE,"^",9):"D:"_FID_":"_$PIECE(NODE,"^",10),1:"B:"_IEN_":"_$$GETCODE($PIECE(NODE,"^",2),$PIECE(NODE,"^")))
+83 IF $LENGTH(IBDFSA(IBLC))+$LENGTH(IBX)<252
SET IBDFSA(IBLC)=IBDFSA(IBLC)_IBX
QUIT
+84 DO BLDARY^IBDFBKS("~~~"_IBX)
End DoDot:4
End DoDot:3
End DoDot:2
+85 SET IBDFSA(IBLC)=IBDFSA(IBLC)_""";"
End DoDot:1
+86 ;
+87 ;** MAP **
+88 IF (TYPE=0)!(TYPE=3)
DO BLDARY^IBDFBKS(" MAP = "" ,"_$TRANSLATE($PIECE(NODE,"^",6),",;"," ")_""";")
+89 ;
+90 IF (TYPE=1)!(TYPE=2)
Begin DoDot:1
+91 DO BLDARY^IBDFBKS(" MAP = "" ")
+92 ;
+93 SET COL=""
FOR
SET COL=$ORDER(@SCAN@(PAGE,FID,TYPE,COL))
if COL=""
QUIT
SET ROW=""
FOR
SET ROW=$ORDER(@SCAN@(PAGE,FID,TYPE,COL,ROW))
if ROW=""
QUIT
SET IEN=$ORDER(@SCAN@(PAGE,FID,TYPE,COL,ROW,0))
Begin DoDot:2
+94 IF IEN
SET NODE=$GET(@SCAN@(PAGE,FID,TYPE,COL,ROW,IEN))
+95 IF $LENGTH(IBDFSA(IBLC))+$LENGTH($TRANSLATE($PIECE(NODE,"^",6),",;"," "))<252
SET IBDFSA(IBLC)=IBDFSA(IBLC)_","_$TRANSLATE($PIECE(NODE,"^",6),",;"," ")
QUIT
+96 DO BLDARY^IBDFBKS("~~~"_","_$TRANSLATE($PIECE(NODE,"^",6),",;"," "))
End DoDot:2
+97 SET IBDFSA(IBLC)=IBDFSA(IBLC)_""";"
End DoDot:1
+98 IF $DATA(OTHER($PIECE(FID,"("),IEN))
SET OTHER($PIECE(FID,"("),IEN)=FIELD
+99 QUIT
+100 ;
FINDBUB(Y,X) ;
+1 ;converts row,col of bubble to paperkeyboard points, with proper offsets added - call by reference
+2 SET X=((COL*COLWIDTH)+(XBUBOS+XOFFSET))*CONVERT
+3 ;S X=1+$FN(X,"",0)
+4 SET X=$FNUMBER(X,"",0)
+5 SET Y=((ROW*ROWHT)+(YOFFSET+YBUBOS))*CONVERT
+6 ;S Y=1+$FN(Y,"",0)
+7 SET Y=$FNUMBER(Y,"",0)
+8 QUIT
+9 ;
ADDTOBEG(TEXT) ;
+1 IF '$DATA(BEGIN)
SET BEGIN(1)=" BEGIN = {"
SET BLN=1
+2 SET BLN=BLN+1
+3 SET BEGIN(BLN)=TEXT
+4 QUIT
+5 ;
PRINTBEG ;
+1 IF $DATA(BEGIN)
Begin DoDot:1
+2 SET BLN=0
FOR
SET BLN=$ORDER(BEGIN(BLN))
if 'BLN
QUIT
DO BLDARY^IBDFBKS(BEGIN(BLN))
+3 DO BLDARY^IBDFBKS(" };")
+4 KILL BEGIN
End DoDot:1
+5 QUIT
+6 ;
ADDTOEND(TEXT) ;
+1 IF '$DATA(END)
SET END(1)=" END = {"
SET LN=1
+2 SET LN=LN+1
+3 SET END(LN)=TEXT
+4 QUIT
+5 ;
PRINTEND ;
+1 IF $DATA(END)
Begin DoDot:1
+2 SET LN=0
FOR
SET LN=$ORDER(END(LN))
if 'LN
QUIT
DO BLDARY^IBDFBKS(END(LN))
+3 DO BLDARY^IBDFBKS(" };")
+4 KILL END
End DoDot:1
+5 IF PRIORPG'=PAGE
DO PAGEEND(PRIORPG)
+6 IF PAGE>1
IF PRIORPG'=PAGE
DO PAGETOP(PAGE)
+7 SET PRIORPG=PAGE
+8 QUIT
+9 ;
GETCODE(VALUE,PI) ;returns the value after passing it through the output transform contained in the package interface file
+1 ;
+2 NEW X,Y
SET (Y,X)=VALUE
+3 ;
+4 IF PI
XECUTE $GET(^IBE(357.6,PI,14))
+5 QUIT Y
+6 ;
PAGEEND(PAGE) ;end of page processing
+1 NEW FLD
+2 SET FIELD=FIELD+1
+3 FOR COUNT=1:1
SET LINE=$TEXT(BOTTOM+COUNT^IBDFBKS1)
SET TAG=$PIECE(LINE,";;")
SET LINE=$PIECE(LINE,";;",2)
if TAG["QUIT"
QUIT
Begin DoDot:1
+4 IF TAG["NUMBER"
DO BLDARY^IBDFBKS("FIELD ' "_FIELD)
QUIT
+5 IF TAG["NAME"
DO BLDARY^IBDFBKS(" NAME = ""BOTTOM OF PAGE"_PAGE_""";")
QUIT
+6 IF TAG["PAGE"
DO BLDARY^IBDFBKS(" PAGE = "_PAGE_";")
QUIT
+7 IF TAG["SAVE"
Begin DoDot:2
+8 DO BLDARY^IBDFBKS(" Save = STRCAT(\""SAVEFORM(\"",ITOA(GETIVALUE(7)));")
+9 DO BLDARY^IBDFBKS(" Save = STRCAT(Save,"","_PAGE_",,V)"");")
+10 ;
End DoDot:2
QUIT
+11 IF TAG["EXPORT"
Begin DoDot:2
+12 DO BLDARY^IBDFBKS(" DDEEXEC(ddechan,\""$$NEW$$("");")
+13 DO BLDARY^IBDFBKS(" Data=\""$$ADD$$(FORMTYPE="_IBFORMID_",\"";")
+14 DO BLDARY^IBDFBKS(" DDEEXEC(ddechan,Data);")
+15 DO BLDARY^IBDFBKS(" Data=STRCAT(\""$$ADD$$(FORMID=\"",ITOA(GETIVALUE(7)));")
+16 DO BLDARY^IBDFBKS(" Data=STRCAT(Data,\"",\"");")
+17 DO BLDARY^IBDFBKS(" DDEEXEC(ddechan,Data);")
+18 DO BLDARY^IBDFBKS(" Data=\""$$ADD$$(PAGE="_PAGE_",\"";")
+19 DO BLDARY^IBDFBKS(" DDEEXEC(ddechan,Data);")
+20 DO BLDARY^IBDFBKS(" Data=\""$$ADD$$(DATA=,\"";")
+21 DO BLDARY^IBDFBKS(" DDEEXEC(ddechan,Data);")
+22 ;
+23 DO FIELDS^IBDFBKS4
End DoDot:2
QUIT
+24 DO BLDARY^IBDFBKS(LINE)
End DoDot:1
+25 QUIT
+26 ;
+27 ;;;.I TAG["EXPORT" D Q
+28 ;;;D BLDARY^IBDFBKS(" Data=STRCAT(\""FORMTYPE="_IBFORMID_"\"",RS);")
+29 ;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,\""FORMID=\"");")
+30 ;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,ITOA(GETIVALUE(7)));")
+31 ;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,RS);")
+32 ;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,\""PAGE="_PAGE_"\"");")
+33 ;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,RS);")
+34 ;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,\""DATA=\"");")
+35 ;;;D BLDARY^IBDFBKS(" Data=STRCAT(Data,RS);")
+36 ;;;..D BLDARY^IBDFBKS(" DDEEXEC(ddechan,Data);")
+37 ;
PAGETOP(PAGE) ;add field for top of page
+1 SET FIELD=FIELD+1
+2 FOR COUNT=1:1
SET LINE=$TEXT(TOPOFPG+COUNT^IBDFBKS1)
SET TAG=$PIECE(LINE,";;")
SET LINE=$PIECE(LINE,";;",2)
if TAG["QUIT"
QUIT
Begin DoDot:1
+3 IF TAG["NUMBER"
DO BLDARY^IBDFBKS("FIELD ' "_FIELD)
QUIT
+4 IF TAG["FLDNAME"
DO BLDARY^IBDFBKS(" NAME = ""TOP OF PAGE "_PAGE_""";")
QUIT
+5 IF TAG["PAGE"
DO BLDARY^IBDFBKS(" PAGE = "_PAGE_";")
QUIT
+6 DO BLDARY^IBDFBKS(LINE)
End DoDot:1
+7 QUIT
CKNAM(NAME) ; - format name with \ for paperkey when displaying name
+1 FOR CHAR="\","'"
IF NAME[CHAR
Begin DoDot:1
+2 FOR A=1:1:$LENGTH(NAME,CHAR)-1
SET NAME=$PIECE(NAME,CHAR,1,A)_"\"_CHAR_$PIECE(NAME,CHAR,A+1,$LENGTH(NAME,CHAR))
End DoDot:1
+3 QUIT NAME
