- 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 Feb 19, 2025@00:18:26 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