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

IBDFC2.m

Go to the documentation of this file.
  1. IBDFC2 ;ALB/CJM - ENCOUNTER FORM - converts a form for scanning ;MAR 3, 1995
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
  1. ;
  1. CONVERT(OLDFORM) ;
  1. N IBCNVRT,IBFORM,IBDASK
  1. S (IBCNVRT,IBFORM)=""
  1. S IBCNVRT("BLOCK OFFSET")=0
  1. ;S IBDASK("ADDOTHER")=$$ASKOTH^IBDFC2B G:IBDASK("ADDOTHER")<0 CONVQ
  1. ;S IBDASK("AUTOCHG")=$$ASKAUTO^IBDFC2B G:IBDASK("AUTOCHG")<0 CONVQ
  1. D COPYFORM(OLDFORM,.IBFORM,.IBCNVRT)
  1. G:('IBFORM)!('IBCNVRT) CONVQ
  1. D FILE357
  1. G:'$$FORMDSCR^IBDFU1C(.IBFORM) CONVQ
  1. D BLOCKS
  1. D COMPILE^IBDF19
  1. D PAGEINFO
  1. ;
  1. CONVQ Q IBFORM
  1. ;
  1. PAGEINFO ;determines what pages must be scanned
  1. N PG,FORMTYPE,LN,TOP,BOT,IEN,NODE
  1. S FORMTYPE=$P($G(^IBE(357,IBFORM,0)),"^",13) Q:'FORMTYPE
  1. F PG=1:1:IBFORM("PAGES") D
  1. .S TOP=(PG-1)*IBFORM("PAGE_HT"),BOT=TOP+IBFORM("PAGE_HT")
  1. .S LN=$O(^IBD(357.95,FORMTYPE,1,"B",TOP-1))
  1. .I 'LN!(LN>BOT) S LN=$O(^IBD(357.95,FORMTYPE,2,"B",TOP-1)) Q:'LN!(LN>BOT)
  1. .;the page should be in file 357
  1. .S IEN=$O(^IBE(357,IBFORM,2,"B",PG,0)) I 'IEN D
  1. ..S NODE=$G(^IBE(357,IBFORM,2,0))
  1. ..F IEN=+$P(NODE,"^",3)+1:1:1 Q:'$D(^IBE(357,IBFORM,2,IEN))
  1. ..S $P(^IBE(357,IBFORM,2,IEN,0),"^")=PG
  1. ..S ^IBE(357,IBFORM,2,"B",PG,IEN)=""
  1. ..S $P(NODE,"^",2)="357.02I",$P(NODE,"^",4)=$P(NODE,"^",4)+1,$P(NODE,"^",3)=IEN,^IBE(357,IBFORM,2,0)=NODE
  1. .S $P(^IBE(357,IBFORM,2,IEN,0),"^",2)=1
  1. .;
  1. .;the page should also be in file 357.95 (form definition)
  1. .S IEN=$O(^IBD(357.95,FORMTYPE,3,"B",PG,0)) I 'IEN D
  1. ..S NODE=$G(^IBD(357.95,FORMTYPE,3,0))
  1. ..F IEN=+$P(NODE,"^",3)+1:1:1 Q:'$D(^IBD(357.95,FORMTYPE,3,IEN))
  1. ..S $P(^IBD(357.95,FORMTYPE,3,IEN,0),"^")=PG
  1. ..S ^IBD(357.95,FORMTYPE,3,"B",PG,IEN)=""
  1. ..S $P(NODE,"^",2)=357.953,$P(NODE,"^",4)=$P(NODE,"^",4)+1,$P(NODE,"^",3)=IEN,^IBD(357.95,FORMTYPE,3,0)=NODE
  1. .S $P(^IBD(357.95,FORMTYPE,3,IEN,0),"^",2)=1
  1. Q
  1. ;
  1. FILE357 ;
  1. N NODE,FIELD,LENGTH
  1. S NODE=$G(^IBE(357,IBFORM,0))
  1. ;check right margin
  1. S FIELD=$P(NODE,"^",9) I FIELD'=133 S $P(NODE,"^",9)=133 D:FIELD'=132 WARNING("RIGHT MARGIN CHANGED TO 133 FROM "_FIELD)
  1. S (LENGTH,FIELD)=$P(NODE,"^",10) I FIELD'=80 D WARNING("PAGE LENGTH CHANGED TO 80 FROM "_LENGTH) D
  1. .S $P(NODE,"^",10)=80
  1. .I LENGTH<80 S IBCNVRT("BLOCK OFFSET")=80-LENGTH
  1. .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
  1. S $P(NODE,"^",6)=1
  1. S $P(NODE,"^",12)=1
  1. S $P(NODE,"^",14)=1
  1. S $P(NODE,"^",15)="p"
  1. S $P(NODE,"^",16)=1
  1. S $P(NODE,"^",17)=+$G(^DD(357,0,"VR")) S:$P(NODE,"^",17)<2.1 $P(NODE,"^",17)="3.0"
  1. S ^IBE(357,IBFORM,0)=NODE
  1. Q
  1. COPYFORM(OLDFORM,NEWFORM,IBCNVRT) ;
  1. ;copies OLDFORM->NEWFORM and creates an entry in file 359=IBCNVRT
  1. N NEWNAME,OLDNAME
  1. S OLDNAME=$P($G(^IBE(357,OLDFORM,0)),"^")
  1. S NEWNAME="CNV."_$E(OLDNAME,1,41)
  1. S NEWFORM=$$COPYFORM^IBDFU2C(OLDFORM,357,357,NEWNAME,0)
  1. S IBCNVRT=$$ADDTO359(NEWFORM,OLDFORM,OLDNAME)
  1. Q
  1. ;
  1. ADDTO359(NEWFORM,OLDFORM,OLDNAME) ;
  1. ;create an entry in file 359, Converted Forms
  1. N IBCNVRT,DIC
  1. K DIC,DO,DA,DINUM
  1. S DIC="^IBD(359,",X=NEWFORM,DIC(0)=""
  1. D FILE^DICN K DIC,DIE,DA,DINUM
  1. S IBCNVRT=+Y
  1. Q:IBCNVRT<0 0
  1. S NODE=NEWFORM_"^"_OLDFORM_"^"_OLDNAME_"^"_DT
  1. S ^IBD(359,IBCNVRT,0)=NODE
  1. S ^IBD(359,IBCNVRT,1,0)="^^0^0^^"
  1. S DIK="^IBD(359,",DA=IBCNVRT D IX1^DIK
  1. Q IBCNVRT
  1. ;
  1. WARNING(WARNING) ;
  1. ;adds the warning to file 359, entry=IBCNVRT
  1. N CNT,NUM,NODE
  1. S NODE=$G(^IBD(359,IBCNVRT,1,0))
  1. S CNT=$P(NODE,"^",4),NUM=$P(NODE,"^",3)
  1. S CNT=CNT+1,NUM=NUM+1
  1. S WARNING(1)=NUM_") "_$E(WARNING,1,77-$L(CNT))
  1. S WARNING(2)=$E(WARNING,77-$L(CNT),245)
  1. I WARNING(2)]"" S WARNING(1)=WARNING(1)_"-",WARNING(2)=" "_WARNING(2)
  1. S ^IBD(359,IBCNVRT,1,CNT,0)=WARNING(1)
  1. I WARNING(2)]"" S CNT=CNT+1,^IBD(359,IBCNVRT,1,CNT,0)=WARNING(2)
  1. S $P(NODE,"^",4)=CNT,$P(NODE,"^",3)=NUM,^IBD(359,IBCNVRT,1,0)=NODE
  1. Q
  1. ;
  1. BLOCKS ;loops through the blocks
  1. N IBBLK,NODE,PAGE,IBLIST
  1. S IBBLK=0 F S IBBLK=$O(^IBE(357.1,"C",IBFORM,IBBLK)) Q:'IBBLK D
  1. .Q:$$BLKDESCR^IBDFU1B(.IBBLK)
  1. .I IBBLK("NAME")="FORM NUMBER" D DLTBLK^IBDFU3(IBBLK,IBFORM,357.1) Q
  1. .D UNCMPBLK^IBDF19(IBBLK)
  1. .S NODE=$G(^IBE(357.1,IBBLK,0))
  1. .;
  1. .;if the page is bigger, shift the blocks down
  1. .I IBCNVRT("BLOCK OFFSET") D
  1. ..N Y
  1. ..S Y=IBBLK("Y")+(IBCNVRT("BLOCK OFFSET")*IBBLK("PAGE"))
  1. ..S PAGE=1+(Y\IBFORM("PAGE_HT"))
  1. ..Q:PAGE'>1
  1. ..S Y=IBBLK("Y")+(IBCNVRT("BLOCK OFFSET")*(PAGE-1))
  1. ..S PAGE=1+(Y\IBFORM("PAGE_HT"))
  1. ..S $P(NODE,"^",4)=Y,IBBLK("Y")=Y,IBBLK("PAGE")=PAGE
  1. .;
  1. .;does the block overlap page boundry?
  1. .S PAGE=1+((IBBLK("Y")+IBBLK("H")-1)\IBFORM("PAGE_HT"))
  1. .I PAGE'=IBBLK("PAGE") D WARNING("THE BLOCK '"_IBBLK("NAME")_"' OVERLAPS PAGE BOUNDRIES")
  1. .;
  1. .I IBBLK("X")+IBBLK("W")>133 D WARNING("THE BLOCK '"_IBBLK("NAME")_"' EXTENDS PAST THE RIGHT MARGIN")
  1. .;
  1. .;use reverse printing for block headers - it's new and looks good
  1. .I IBBLK("BOX")=1,IBBLK("HDR")'="",IBBLK("HDISP")["U",IBBLK("HDISP")["C",IBBLK("HDISP")'["R" S $P(NODE,"^",12)="RC"
  1. .
  1. .S ^IBE(357.1,IBBLK,0)=NODE
  1. .K NODE,PAGE,Y
  1. .;
  1. .;handle the selection lists
  1. .S IBLIST=0 F S IBLIST=$O(^IBE(357.2,"C",IBBLK,IBLIST)) Q:'IBLIST D
  1. ..Q:$$LSTDESCR^IBDFU1(.IBLIST)
  1. ..I $G(IBDASK("ADDOHTER")) D ADDOTHER^IBDFC2B
  1. ..D CHKVISIT^IBDFC2B
  1. ..D BUBBLES^IBDFC2A(.IBLIST)
  1. ..Q:$$LSTDESCR^IBDFU1(.IBLIST)
  1. ..D CKVALUES^IBDFC2B
  1. Q