IBDFC2 ;ALB/CJM - ENCOUNTER FORM - converts a form for scanning ;MAR 3, 1995
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
CONVERT(OLDFORM) ;
N IBCNVRT,IBFORM,IBDASK
S (IBCNVRT,IBFORM)=""
S IBCNVRT("BLOCK OFFSET")=0
;S IBDASK("ADDOTHER")=$$ASKOTH^IBDFC2B G:IBDASK("ADDOTHER")<0 CONVQ
;S IBDASK("AUTOCHG")=$$ASKAUTO^IBDFC2B G:IBDASK("AUTOCHG")<0 CONVQ
D COPYFORM(OLDFORM,.IBFORM,.IBCNVRT)
G:('IBFORM)!('IBCNVRT) CONVQ
D FILE357
G:'$$FORMDSCR^IBDFU1C(.IBFORM) CONVQ
D BLOCKS
D COMPILE^IBDF19
D PAGEINFO
;
CONVQ Q IBFORM
;
PAGEINFO ;determines what pages must be scanned
N PG,FORMTYPE,LN,TOP,BOT,IEN,NODE
S FORMTYPE=$P($G(^IBE(357,IBFORM,0)),"^",13) Q:'FORMTYPE
F PG=1:1:IBFORM("PAGES") D
.S TOP=(PG-1)*IBFORM("PAGE_HT"),BOT=TOP+IBFORM("PAGE_HT")
.S LN=$O(^IBD(357.95,FORMTYPE,1,"B",TOP-1))
.I 'LN!(LN>BOT) S LN=$O(^IBD(357.95,FORMTYPE,2,"B",TOP-1)) Q:'LN!(LN>BOT)
.;the page should be in file 357
.S IEN=$O(^IBE(357,IBFORM,2,"B",PG,0)) I 'IEN D
..S NODE=$G(^IBE(357,IBFORM,2,0))
..F IEN=+$P(NODE,"^",3)+1:1:1 Q:'$D(^IBE(357,IBFORM,2,IEN))
..S $P(^IBE(357,IBFORM,2,IEN,0),"^")=PG
..S ^IBE(357,IBFORM,2,"B",PG,IEN)=""
..S $P(NODE,"^",2)="357.02I",$P(NODE,"^",4)=$P(NODE,"^",4)+1,$P(NODE,"^",3)=IEN,^IBE(357,IBFORM,2,0)=NODE
.S $P(^IBE(357,IBFORM,2,IEN,0),"^",2)=1
.;
.;the page should also be in file 357.95 (form definition)
.S IEN=$O(^IBD(357.95,FORMTYPE,3,"B",PG,0)) I 'IEN D
..S NODE=$G(^IBD(357.95,FORMTYPE,3,0))
..F IEN=+$P(NODE,"^",3)+1:1:1 Q:'$D(^IBD(357.95,FORMTYPE,3,IEN))
..S $P(^IBD(357.95,FORMTYPE,3,IEN,0),"^")=PG
..S ^IBD(357.95,FORMTYPE,3,"B",PG,IEN)=""
..S $P(NODE,"^",2)=357.953,$P(NODE,"^",4)=$P(NODE,"^",4)+1,$P(NODE,"^",3)=IEN,^IBD(357.95,FORMTYPE,3,0)=NODE
.S $P(^IBD(357.95,FORMTYPE,3,IEN,0),"^",2)=1
Q
;
FILE357 ;
N NODE,FIELD,LENGTH
S NODE=$G(^IBE(357,IBFORM,0))
;check right margin
S FIELD=$P(NODE,"^",9) I FIELD'=133 S $P(NODE,"^",9)=133 D:FIELD'=132 WARNING("RIGHT MARGIN CHANGED TO 133 FROM "_FIELD)
S (LENGTH,FIELD)=$P(NODE,"^",10) I FIELD'=80 D WARNING("PAGE LENGTH CHANGED TO 80 FROM "_LENGTH) D
.S $P(NODE,"^",10)=80
.I LENGTH<80 S IBCNVRT("BLOCK OFFSET")=80-LENGTH
.I LENGTH>80 S FIELD=$P(NODE,"^",11),LENGTH=(LENGTH*FIELD)+79,LENGTH=LENGTH\80 I LENGTH'=FIELD D WARNING("THE NUMBER OF PAGES CHANGED TO "_LENGTH_" FROM "_FIELD) S $P(NODE,"^",11)=LENGTH
S $P(NODE,"^",6)=1
S $P(NODE,"^",12)=1
S $P(NODE,"^",14)=1
S $P(NODE,"^",15)="p"
S $P(NODE,"^",16)=1
S $P(NODE,"^",17)=+$G(^DD(357,0,"VR")) S:$P(NODE,"^",17)<2.1 $P(NODE,"^",17)="3.0"
S ^IBE(357,IBFORM,0)=NODE
Q
COPYFORM(OLDFORM,NEWFORM,IBCNVRT) ;
;copies OLDFORM->NEWFORM and creates an entry in file 359=IBCNVRT
N NEWNAME,OLDNAME
S OLDNAME=$P($G(^IBE(357,OLDFORM,0)),"^")
S NEWNAME="CNV."_$E(OLDNAME,1,41)
S NEWFORM=$$COPYFORM^IBDFU2C(OLDFORM,357,357,NEWNAME,0)
S IBCNVRT=$$ADDTO359(NEWFORM,OLDFORM,OLDNAME)
Q
;
ADDTO359(NEWFORM,OLDFORM,OLDNAME) ;
;create an entry in file 359, Converted Forms
N IBCNVRT,DIC
K DIC,DO,DA,DINUM
S DIC="^IBD(359,",X=NEWFORM,DIC(0)=""
D FILE^DICN K DIC,DIE,DA,DINUM
S IBCNVRT=+Y
Q:IBCNVRT<0 0
S NODE=NEWFORM_"^"_OLDFORM_"^"_OLDNAME_"^"_DT
S ^IBD(359,IBCNVRT,0)=NODE
S ^IBD(359,IBCNVRT,1,0)="^^0^0^^"
S DIK="^IBD(359,",DA=IBCNVRT D IX1^DIK
Q IBCNVRT
;
WARNING(WARNING) ;
;adds the warning to file 359, entry=IBCNVRT
N CNT,NUM,NODE
S NODE=$G(^IBD(359,IBCNVRT,1,0))
S CNT=$P(NODE,"^",4),NUM=$P(NODE,"^",3)
S CNT=CNT+1,NUM=NUM+1
S WARNING(1)=NUM_") "_$E(WARNING,1,77-$L(CNT))
S WARNING(2)=$E(WARNING,77-$L(CNT),245)
I WARNING(2)]"" S WARNING(1)=WARNING(1)_"-",WARNING(2)=" "_WARNING(2)
S ^IBD(359,IBCNVRT,1,CNT,0)=WARNING(1)
I WARNING(2)]"" S CNT=CNT+1,^IBD(359,IBCNVRT,1,CNT,0)=WARNING(2)
S $P(NODE,"^",4)=CNT,$P(NODE,"^",3)=NUM,^IBD(359,IBCNVRT,1,0)=NODE
Q
;
BLOCKS ;loops through the blocks
N IBBLK,NODE,PAGE,IBLIST
S IBBLK=0 F S IBBLK=$O(^IBE(357.1,"C",IBFORM,IBBLK)) Q:'IBBLK D
.Q:$$BLKDESCR^IBDFU1B(.IBBLK)
.I IBBLK("NAME")="FORM NUMBER" D DLTBLK^IBDFU3(IBBLK,IBFORM,357.1) Q
.D UNCMPBLK^IBDF19(IBBLK)
.S NODE=$G(^IBE(357.1,IBBLK,0))
.;
.;if the page is bigger, shift the blocks down
.I IBCNVRT("BLOCK OFFSET") D
..N Y
..S Y=IBBLK("Y")+(IBCNVRT("BLOCK OFFSET")*IBBLK("PAGE"))
..S PAGE=1+(Y\IBFORM("PAGE_HT"))
..Q:PAGE'>1
..S Y=IBBLK("Y")+(IBCNVRT("BLOCK OFFSET")*(PAGE-1))
..S PAGE=1+(Y\IBFORM("PAGE_HT"))
..S $P(NODE,"^",4)=Y,IBBLK("Y")=Y,IBBLK("PAGE")=PAGE
.;
.;does the block overlap page boundry?
.S PAGE=1+((IBBLK("Y")+IBBLK("H")-1)\IBFORM("PAGE_HT"))
.I PAGE'=IBBLK("PAGE") D WARNING("THE BLOCK '"_IBBLK("NAME")_"' OVERLAPS PAGE BOUNDRIES")
.;
.I IBBLK("X")+IBBLK("W")>133 D WARNING("THE BLOCK '"_IBBLK("NAME")_"' EXTENDS PAST THE RIGHT MARGIN")
.;
.;use reverse printing for block headers - it's new and looks good
.I IBBLK("BOX")=1,IBBLK("HDR")'="",IBBLK("HDISP")["U",IBBLK("HDISP")["C",IBBLK("HDISP")'["R" S $P(NODE,"^",12)="RC"
.
.S ^IBE(357.1,IBBLK,0)=NODE
.K NODE,PAGE,Y
.;
.;handle the selection lists
.S IBLIST=0 F S IBLIST=$O(^IBE(357.2,"C",IBBLK,IBLIST)) Q:'IBLIST D
..Q:$$LSTDESCR^IBDFU1(.IBLIST)
..I $G(IBDASK("ADDOHTER")) D ADDOTHER^IBDFC2B
..D CHKVISIT^IBDFC2B
..D BUBBLES^IBDFC2A(.IBLIST)
..Q:$$LSTDESCR^IBDFU1(.IBLIST)
..D CKVALUES^IBDFC2B
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFC2 5359 printed Oct 16, 2024@18:52:46 Page 2
IBDFC2 ;ALB/CJM - ENCOUNTER FORM - converts a form for scanning ;MAR 3, 1995
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
CONVERT(OLDFORM) ;
+1 NEW IBCNVRT,IBFORM,IBDASK
+2 SET (IBCNVRT,IBFORM)=""
+3 SET IBCNVRT("BLOCK OFFSET")=0
+4 ;S IBDASK("ADDOTHER")=$$ASKOTH^IBDFC2B G:IBDASK("ADDOTHER")<0 CONVQ
+5 ;S IBDASK("AUTOCHG")=$$ASKAUTO^IBDFC2B G:IBDASK("AUTOCHG")<0 CONVQ
+6 DO COPYFORM(OLDFORM,.IBFORM,.IBCNVRT)
+7 if ('IBFORM)!('IBCNVRT)
GOTO CONVQ
+8 DO FILE357
+9 if '$$FORMDSCR^IBDFU1C(.IBFORM)
GOTO CONVQ
+10 DO BLOCKS
+11 DO COMPILE^IBDF19
+12 DO PAGEINFO
+13 ;
CONVQ QUIT IBFORM
+1 ;
PAGEINFO ;determines what pages must be scanned
+1 NEW PG,FORMTYPE,LN,TOP,BOT,IEN,NODE
+2 SET FORMTYPE=$PIECE($GET(^IBE(357,IBFORM,0)),"^",13)
if 'FORMTYPE
QUIT
+3 FOR PG=1:1:IBFORM("PAGES")
Begin DoDot:1
+4 SET TOP=(PG-1)*IBFORM("PAGE_HT")
SET BOT=TOP+IBFORM("PAGE_HT")
+5 SET LN=$ORDER(^IBD(357.95,FORMTYPE,1,"B",TOP-1))
+6 IF 'LN!(LN>BOT)
SET LN=$ORDER(^IBD(357.95,FORMTYPE,2,"B",TOP-1))
if 'LN!(LN>BOT)
QUIT
+7 ;the page should be in file 357
+8 SET IEN=$ORDER(^IBE(357,IBFORM,2,"B",PG,0))
IF 'IEN
Begin DoDot:2
+9 SET NODE=$GET(^IBE(357,IBFORM,2,0))
+10 FOR IEN=+$PIECE(NODE,"^",3)+1:1:1
if '$DATA(^IBE(357,IBFORM,2,IEN))
QUIT
+11 SET $PIECE(^IBE(357,IBFORM,2,IEN,0),"^")=PG
+12 SET ^IBE(357,IBFORM,2,"B",PG,IEN)=""
+13 SET $PIECE(NODE,"^",2)="357.02I"
SET $PIECE(NODE,"^",4)=$PIECE(NODE,"^",4)+1
SET $PIECE(NODE,"^",3)=IEN
SET ^IBE(357,IBFORM,2,0)=NODE
End DoDot:2
+14 SET $PIECE(^IBE(357,IBFORM,2,IEN,0),"^",2)=1
+15 ;
+16 ;the page should also be in file 357.95 (form definition)
+17 SET IEN=$ORDER(^IBD(357.95,FORMTYPE,3,"B",PG,0))
IF 'IEN
Begin DoDot:2
+18 SET NODE=$GET(^IBD(357.95,FORMTYPE,3,0))
+19 FOR IEN=+$PIECE(NODE,"^",3)+1:1:1
if '$DATA(^IBD(357.95,FORMTYPE,3,IEN))
QUIT
+20 SET $PIECE(^IBD(357.95,FORMTYPE,3,IEN,0),"^")=PG
+21 SET ^IBD(357.95,FORMTYPE,3,"B",PG,IEN)=""
+22 SET $PIECE(NODE,"^",2)=357.953
SET $PIECE(NODE,"^",4)=$PIECE(NODE,"^",4)+1
SET $PIECE(NODE,"^",3)=IEN
SET ^IBD(357.95,FORMTYPE,3,0)=NODE
End DoDot:2
+23 SET $PIECE(^IBD(357.95,FORMTYPE,3,IEN,0),"^",2)=1
End DoDot:1
+24 QUIT
+25 ;
FILE357 ;
+1 NEW NODE,FIELD,LENGTH
+2 SET NODE=$GET(^IBE(357,IBFORM,0))
+3 ;check right margin
+4 SET FIELD=$PIECE(NODE,"^",9)
IF FIELD'=133
SET $PIECE(NODE,"^",9)=133
if FIELD'=132
DO WARNING("RIGHT MARGIN CHANGED TO 133 FROM "_FIELD)
+5 SET (LENGTH,FIELD)=$PIECE(NODE,"^",10)
IF FIELD'=80
DO WARNING("PAGE LENGTH CHANGED TO 80 FROM "_LENGTH)
Begin DoDot:1
+6 SET $PIECE(NODE,"^",10)=80
+7 IF LENGTH<80
SET IBCNVRT("BLOCK OFFSET")=80-LENGTH
+8 IF LENGTH>80
SET FIELD=$PIECE(NODE,"^",11)
SET LENGTH=(LENGTH*FIELD)+79
SET LENGTH=LENGTH\80
IF LENGTH'=FIELD
DO WARNING("THE NUMBER OF PAGES CHANGED TO "_LENGTH_" FROM "_FIELD)
SET $PIECE(NODE,"^",11)=LENGTH
End DoDot:1
+9 SET $PIECE(NODE,"^",6)=1
+10 SET $PIECE(NODE,"^",12)=1
+11 SET $PIECE(NODE,"^",14)=1
+12 SET $PIECE(NODE,"^",15)="p"
+13 SET $PIECE(NODE,"^",16)=1
+14 SET $PIECE(NODE,"^",17)=+$GET(^DD(357,0,"VR"))
if $PIECE(NODE,"^",17)<2.1
SET $PIECE(NODE,"^",17)="3.0"
+15 SET ^IBE(357,IBFORM,0)=NODE
+16 QUIT
COPYFORM(OLDFORM,NEWFORM,IBCNVRT) ;
+1 ;copies OLDFORM->NEWFORM and creates an entry in file 359=IBCNVRT
+2 NEW NEWNAME,OLDNAME
+3 SET OLDNAME=$PIECE($GET(^IBE(357,OLDFORM,0)),"^")
+4 SET NEWNAME="CNV."_$EXTRACT(OLDNAME,1,41)
+5 SET NEWFORM=$$COPYFORM^IBDFU2C(OLDFORM,357,357,NEWNAME,0)
+6 SET IBCNVRT=$$ADDTO359(NEWFORM,OLDFORM,OLDNAME)
+7 QUIT
+8 ;
ADDTO359(NEWFORM,OLDFORM,OLDNAME) ;
+1 ;create an entry in file 359, Converted Forms
+2 NEW IBCNVRT,DIC
+3 KILL DIC,DO,DA,DINUM
+4 SET DIC="^IBD(359,"
SET X=NEWFORM
SET DIC(0)=""
+5 DO FILE^DICN
KILL DIC,DIE,DA,DINUM
+6 SET IBCNVRT=+Y
+7 if IBCNVRT<0
QUIT 0
+8 SET NODE=NEWFORM_"^"_OLDFORM_"^"_OLDNAME_"^"_DT
+9 SET ^IBD(359,IBCNVRT,0)=NODE
+10 SET ^IBD(359,IBCNVRT,1,0)="^^0^0^^"
+11 SET DIK="^IBD(359,"
SET DA=IBCNVRT
DO IX1^DIK
+12 QUIT IBCNVRT
+13 ;
WARNING(WARNING) ;
+1 ;adds the warning to file 359, entry=IBCNVRT
+2 NEW CNT,NUM,NODE
+3 SET NODE=$GET(^IBD(359,IBCNVRT,1,0))
+4 SET CNT=$PIECE(NODE,"^",4)
SET NUM=$PIECE(NODE,"^",3)
+5 SET CNT=CNT+1
SET NUM=NUM+1
+6 SET WARNING(1)=NUM_") "_$EXTRACT(WARNING,1,77-$LENGTH(CNT))
+7 SET WARNING(2)=$EXTRACT(WARNING,77-$LENGTH(CNT),245)
+8 IF WARNING(2)]""
SET WARNING(1)=WARNING(1)_"-"
SET WARNING(2)=" "_WARNING(2)
+9 SET ^IBD(359,IBCNVRT,1,CNT,0)=WARNING(1)
+10 IF WARNING(2)]""
SET CNT=CNT+1
SET ^IBD(359,IBCNVRT,1,CNT,0)=WARNING(2)
+11 SET $PIECE(NODE,"^",4)=CNT
SET $PIECE(NODE,"^",3)=NUM
SET ^IBD(359,IBCNVRT,1,0)=NODE
+12 QUIT
+13 ;
BLOCKS ;loops through the blocks
+1 NEW IBBLK,NODE,PAGE,IBLIST
+2 SET IBBLK=0
FOR
SET IBBLK=$ORDER(^IBE(357.1,"C",IBFORM,IBBLK))
if 'IBBLK
QUIT
Begin DoDot:1
+3 if $$BLKDESCR^IBDFU1B(.IBBLK)
QUIT
+4 IF IBBLK("NAME")="FORM NUMBER"
DO DLTBLK^IBDFU3(IBBLK,IBFORM,357.1)
QUIT
+5 DO UNCMPBLK^IBDF19(IBBLK)
+6 SET NODE=$GET(^IBE(357.1,IBBLK,0))
+7 ;
+8 ;if the page is bigger, shift the blocks down
+9 IF IBCNVRT("BLOCK OFFSET")
Begin DoDot:2
+10 NEW Y
+11 SET Y=IBBLK("Y")+(IBCNVRT("BLOCK OFFSET")*IBBLK("PAGE"))
+12 SET PAGE=1+(Y\IBFORM("PAGE_HT"))
+13 if PAGE'>1
QUIT
+14 SET Y=IBBLK("Y")+(IBCNVRT("BLOCK OFFSET")*(PAGE-1))
+15 SET PAGE=1+(Y\IBFORM("PAGE_HT"))
+16 SET $PIECE(NODE,"^",4)=Y
SET IBBLK("Y")=Y
SET IBBLK("PAGE")=PAGE
End DoDot:2
+17 ;
+18 ;does the block overlap page boundry?
+19 SET PAGE=1+((IBBLK("Y")+IBBLK("H")-1)\IBFORM("PAGE_HT"))
+20 IF PAGE'=IBBLK("PAGE")
DO WARNING("THE BLOCK '"_IBBLK("NAME")_"' OVERLAPS PAGE BOUNDRIES")
+21 ;
+22 IF IBBLK("X")+IBBLK("W")>133
DO WARNING("THE BLOCK '"_IBBLK("NAME")_"' EXTENDS PAST THE RIGHT MARGIN")
+23 ;
+24 ;use reverse printing for block headers - it's new and looks good
+25 IF IBBLK("BOX")=1
IF IBBLK("HDR")'=""
IF IBBLK("HDISP")["U"
IF IBBLK("HDISP")["C"
IF IBBLK("HDISP")'["R"
SET $PIECE(NODE,"^",12)="RC"
+26 +27 SET ^IBE(357.1,IBBLK,0)=NODE
+28 KILL NODE,PAGE,Y
+29 ;
+30 ;handle the selection lists
+31 SET IBLIST=0
FOR
SET IBLIST=$ORDER(^IBE(357.2,"C",IBBLK,IBLIST))
if 'IBLIST
QUIT
Begin DoDot:2
+32 if $$LSTDESCR^IBDFU1(.IBLIST)
QUIT
+33 IF $GET(IBDASK("ADDOHTER"))
DO ADDOTHER^IBDFC2B
+34 DO CHKVISIT^IBDFC2B
+35 DO BUBBLES^IBDFC2A(.IBLIST)
+36 if $$LSTDESCR^IBDFU1(.IBLIST)
QUIT
+37 DO CKVALUES^IBDFC2B
End DoDot:2
End DoDot:1
+38 QUIT
