source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFC2.m@ 975

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