source: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFC2.m@ 636

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