- IBDFU2C ;ALB/CJM - ENCOUNTER FORM - (COPYING FORMS) ;AUG12,1993
- ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
- ;
- COPYFORM(OLDFORM,FROMFILE,TOFILE,NEWNAME,TK) ;
- ;copies OLDFORM from FROMFILE to TOFILE, changing the name to NEWNAME if defined (NEWNAME is optional), and the field TOOL KIT to TK if defined
- ;
- Q:'$D(OLDFORM)!'$D(FROMFILE)!'$D(TOFILE) ""
- Q:(FROMFILE'=357)&(FROMFILE'=358) ""
- Q:(TOFILE'=357)&(TOFILE'=358) ""
- Q:'OLDFORM ""
- N NEWFORM,NODE,OLDBLOCK,NEWBLOCK,BLOCK,IBDELETE,FROM,TO,PAGE
- S NODE=$G(^IBE(FROMFILE,OLDFORM,0)) Q:NODE="" ""
- S:($G(NEWNAME)'="") $P(NODE,"^")=NEWNAME
- S:$G(NEWNAME)="" NEWNAME=$P(NODE,"^")
- I $G(TK)=+$G(TK) S $P(NODE,"^",7)=TK
- S $P(NODE,"^",5)=0,$P(NODE,"^",13)=""
- K DIC,DD,DO,DINUM S DIC="^IBE("_TOFILE_",",X=NEWNAME,DIC(0)=""
- D FILE^DICN K DIC,DIE
- S NEWFORM=$S(+Y<0:"",1:+Y)
- I (NEWFORM<0) W !,"Unable to create a new form!" D PAUSE^IBDFU5 Q ""
- ;
- ;the new form should be empty - make sure
- S FROM=$S(FROMFILE[358:358.1,1:357.1)
- S TO=$S(TOFILE[358:358.1,1:357.1)
- S BLOCK="" F S BLOCK=$O(^IBE(TOFILE,"C",NEWFORM,BLOCK)) Q:'BLOCK D
- .I $P($G(^IBE(TO,BLOCK,0)),"^",2)'=NEWFORM D
- ..K ^IBE(TO,"C",NEWFORM,BLOCK),DA S DIK="^IBE("_TO_",",DA=BLOCK D IX1^DIK K DIK,DA
- .E D DLTBLK^IBDFU3(BLOCK,NEWFORM,TO)
- ;
- ;copy old 0 node into the new form
- S ^IBE(TOFILE,NEWFORM,0)=NODE
- ;
- ;now the page multiple
- S NODE=$G(^IBE(FROMFILE,OLDFORM,2,0))
- I NODE'="" S $P(NODE,"^",2)=TOFILE_".02I",^IBE(TOFILE,NEWFORM,2,0)=NODE S PAGE=0 F S PAGE=$O(^IBE(FROMFILE,OLDFORM,2,PAGE)) Q:'PAGE S NODE=$G(^IBE(FROMFILE,OLDFORM,2,PAGE,0)) S:NODE'="" ^IBE(TOFILE,NEWFORM,2,PAGE,0)=NODE
- ;
- ;copy the rest of the form
- S NODE=0 F S NODE=$O(^IBE(FROMFILE,OLDFORM,NODE)) Q:'NODE Q:$G(^IBE(FROMFILE,OLDFORM,NODE))="" S ^IBE(TOFILE,NEWFORM,NODE)=$G(^IBE(FROMFILE,OLDFORM,NODE))
- K DIK S DIK="^IBE("_TOFILE_",",DA=NEWFORM D IX^DIK K DIK
- ;
- ;now copy the blocks into the form
- S OLDBLOCK="" F S OLDBLOCK=$O(^IBE(FROM,"C",OLDFORM,OLDBLOCK)) Q:'OLDBLOCK I $P($G(^IBE(FROM,OLDBLOCK,0)),"^",2)=OLDFORM S NEWBLOCK=$$COPYBLK^IBDFU2(OLDBLOCK,NEWFORM,FROM,TO) W "."
- Q NEWFORM
- ;
- ;
- DELETE(FORM,FILE,ASK) ;deletes the FORM in FILE- if ASK then asks permission first
- Q:'$G(FORM)
- Q:(FILE'=357)&(FILE'=358)
- I $G(ASK) Q:'$$RUSURE^IBDFU5($P($G(^IBE(FILE,FORM,0)),"^"))
- N BLOCK,BLKFILE,CR
- ;might have to delete the bubble translation table
- I FILE=357 D
- .Q:'$$FORMDSCR^IBDFU1C(.FORM)
- .I FORM("TYPE") D KILLTBL^IBDF19(.FORM)
- S BLKFILE=FILE+.1
- S BLOCK="" F S BLOCK=$O(^IBE(BLKFILE,"C",FORM,BLOCK)) Q:'BLOCK D DLTBLK^IBDFU3(BLOCK,FORM,BLKFILE) W "."
- I FILE=357 F CR="AT","AC","AU","AG" K ^IBE(357,CR,FORM)
- K DA S DIK="^IBE("_FILE_",",DA=FORM D ^DIK K DIK,DA
- K FORM
- Q
- NEWNAME(OLDNAME) ;asks the user to select a unique form name
- ;returns "" if unsuccessfull, else the form name
- ;shows OLDNAME as the default if defined
- ;
- N NAME,QUIT S NAME="",QUIT=0
- K DIR S DIR(0)="357,.01A",DIR("A")="New Form Name: ",DIR("?")="Enter a unique name up to 30 characters"
- S DIR("B")="" I $G(OLDNAME)'="",'$O(IBE(357,"B",OLDNAME,0)) S DIR("B")=OLDNAME
- F D Q:QUIT
- .D ^DIR I $D(DIRUT) S QUIT=1 Q
- .I $O(^IBE(357,"B",Y,"")) D
- ..W !,"The form name must be unique, try using the clinic in the name!"
- .E S NAME=Y,QUIT=1
- K DIR
- Q NAME
- TKFORM() ;returns the form TOOL KIT that contains all of the tool kit blocs
- N TKFORM,BLOCK,TKORDER,TK
- S TKFORM=+$O(^IBE(357,"B","TOOL KIT",""))
- I 'TKFORM D
- .K DIC,DD,DO,DINUM S DIC="^IBE(357,",DIC(0)="",X="TOOL KIT"
- .D FILE^DICN K DIC,DIE,DA
- .S TKFORM=$S(+(Y>0):+Y,1:"")
- .Q:'TKFORM
- .S ^IBE(357,TKFORM,0)="TOOL KIT^^CONTAINS ALL OF THE TOOL KIT BLOCKS^^^^1"
- .K DIK S DIK="^IBE(357,",DA=TKFORM D IX1^DIK K DIK
- .S TKORDER=0 F S TKORDER=$O(^IBE(357.1,"D",TKORDER)) Q:'TKORDER S BLOCK=0 F S BLOCK=$O(^IBE(357.1,"D",TKORDER,BLOCK)) Q:'BLOCK D
- ..S TK=$P($G(^IBE(357.1,BLOCK,0)),"^",14) I 'TK K ^IBE(357.1,"D",TKORDER,BLOCK) Q
- ..S FORM=$P($G(^IBE(357.1,BLOCK,0)),"^",2) I FORM'=TKFORM K ^IBE(357.1,"C",FORM,BLOCK) S $P(^IBE(357.1,BLOCK,0),"^",2)=TKFORM K DIK S DIK="^IBE(357.1,",DA=BLOCK,DIK(1)=.02 D EN1^DIK K DIK
- Q TKFORM
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFU2C 4173 printed Feb 19, 2025@00:20:02 Page 2
- IBDFU2C ;ALB/CJM - ENCOUNTER FORM - (COPYING FORMS) ;AUG12,1993
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
- +2 ;
- COPYFORM(OLDFORM,FROMFILE,TOFILE,NEWNAME,TK) ;
- +1 ;copies OLDFORM from FROMFILE to TOFILE, changing the name to NEWNAME if defined (NEWNAME is optional), and the field TOOL KIT to TK if defined
- +2 ;
- +3 if '$DATA(OLDFORM)!'$DATA(FROMFILE)!'$DATA(TOFILE)
- QUIT ""
- +4 if (FROMFILE'=357)&(FROMFILE'=358)
- QUIT ""
- +5 if (TOFILE'=357)&(TOFILE'=358)
- QUIT ""
- +6 if 'OLDFORM
- QUIT ""
- +7 NEW NEWFORM,NODE,OLDBLOCK,NEWBLOCK,BLOCK,IBDELETE,FROM,TO,PAGE
- +8 SET NODE=$GET(^IBE(FROMFILE,OLDFORM,0))
- if NODE=""
- QUIT ""
- +9 if ($GET(NEWNAME)'="")
- SET $PIECE(NODE,"^")=NEWNAME
- +10 if $GET(NEWNAME)=""
- SET NEWNAME=$PIECE(NODE,"^")
- +11 IF $GET(TK)=+$GET(TK)
- SET $PIECE(NODE,"^",7)=TK
- +12 SET $PIECE(NODE,"^",5)=0
- SET $PIECE(NODE,"^",13)=""
- +13 KILL DIC,DD,DO,DINUM
- SET DIC="^IBE("_TOFILE_","
- SET X=NEWNAME
- SET DIC(0)=""
- +14 DO FILE^DICN
- KILL DIC,DIE
- +15 SET NEWFORM=$SELECT(+Y<0:"",1:+Y)
- +16 IF (NEWFORM<0)
- WRITE !,"Unable to create a new form!"
- DO PAUSE^IBDFU5
- QUIT ""
- +17 ;
- +18 ;the new form should be empty - make sure
- +19 SET FROM=$SELECT(FROMFILE[358:358.1,1:357.1)
- +20 SET TO=$SELECT(TOFILE[358:358.1,1:357.1)
- +21 SET BLOCK=""
- FOR
- SET BLOCK=$ORDER(^IBE(TOFILE,"C",NEWFORM,BLOCK))
- if 'BLOCK
- QUIT
- Begin DoDot:1
- +22 IF $PIECE($GET(^IBE(TO,BLOCK,0)),"^",2)'=NEWFORM
- Begin DoDot:2
- +23 KILL ^IBE(TO,"C",NEWFORM,BLOCK),DA
- SET DIK="^IBE("_TO_","
- SET DA=BLOCK
- DO IX1^DIK
- KILL DIK,DA
- End DoDot:2
- +24 IF '$TEST
- DO DLTBLK^IBDFU3(BLOCK,NEWFORM,TO)
- End DoDot:1
- +25 ;
- +26 ;copy old 0 node into the new form
- +27 SET ^IBE(TOFILE,NEWFORM,0)=NODE
- +28 ;
- +29 ;now the page multiple
- +30 SET NODE=$GET(^IBE(FROMFILE,OLDFORM,2,0))
- +31 IF NODE'=""
- SET $PIECE(NODE,"^",2)=TOFILE_".02I"
- SET ^IBE(TOFILE,NEWFORM,2,0)=NODE
- SET PAGE=0
- FOR
- SET PAGE=$ORDER(^IBE(FROMFILE,OLDFORM,2,PAGE))
- if 'PAGE
- QUIT
- SET NODE=$GET(^IBE(FROMFILE,OLDFORM,2,PAGE,0))
- if NODE'=""
- SET ^IBE(TOFILE,NEWFORM,2,PAGE,0)=NODE
- +32 ;
- +33 ;copy the rest of the form
- +34 SET NODE=0
- FOR
- SET NODE=$ORDER(^IBE(FROMFILE,OLDFORM,NODE))
- if 'NODE
- QUIT
- if $GET(^IBE(FROMFILE,OLDFORM,NODE))=""
- QUIT
- SET ^IBE(TOFILE,NEWFORM,NODE)=$GET(^IBE(FROMFILE,OLDFORM,NODE))
- +35 KILL DIK
- SET DIK="^IBE("_TOFILE_","
- SET DA=NEWFORM
- DO IX^DIK
- KILL DIK
- +36 ;
- +37 ;now copy the blocks into the form
- +38 SET OLDBLOCK=""
- FOR
- SET OLDBLOCK=$ORDER(^IBE(FROM,"C",OLDFORM,OLDBLOCK))
- if 'OLDBLOCK
- QUIT
- IF $PIECE($GET(^IBE(FROM,OLDBLOCK,0)),"^",2)=OLDFORM
- SET NEWBLOCK=$$COPYBLK^IBDFU2(OLDBLOCK,NEWFORM,FROM,TO)
- WRITE "."
- +39 QUIT NEWFORM
- +40 ;
- +41 ;
- DELETE(FORM,FILE,ASK) ;deletes the FORM in FILE- if ASK then asks permission first
- +1 if '$GET(FORM)
- QUIT
- +2 if (FILE'=357)&(FILE'=358)
- QUIT
- +3 IF $GET(ASK)
- if '$$RUSURE^IBDFU5($PIECE($GET(^IBE(FILE,FORM,0)),"^"))
- QUIT
- +4 NEW BLOCK,BLKFILE,CR
- +5 ;might have to delete the bubble translation table
- +6 IF FILE=357
- Begin DoDot:1
- +7 if '$$FORMDSCR^IBDFU1C(.FORM)
- QUIT
- +8 IF FORM("TYPE")
- DO KILLTBL^IBDF19(.FORM)
- End DoDot:1
- +9 SET BLKFILE=FILE+.1
- +10 SET BLOCK=""
- FOR
- SET BLOCK=$ORDER(^IBE(BLKFILE,"C",FORM,BLOCK))
- if 'BLOCK
- QUIT
- DO DLTBLK^IBDFU3(BLOCK,FORM,BLKFILE)
- WRITE "."
- +11 IF FILE=357
- FOR CR="AT","AC","AU","AG"
- KILL ^IBE(357,CR,FORM)
- +12 KILL DA
- SET DIK="^IBE("_FILE_","
- SET DA=FORM
- DO ^DIK
- KILL DIK,DA
- +13 KILL FORM
- +14 QUIT
- NEWNAME(OLDNAME) ;asks the user to select a unique form name
- +1 ;returns "" if unsuccessfull, else the form name
- +2 ;shows OLDNAME as the default if defined
- +3 ;
- +4 NEW NAME,QUIT
- SET NAME=""
- SET QUIT=0
- +5 KILL DIR
- SET DIR(0)="357,.01A"
- SET DIR("A")="New Form Name: "
- SET DIR("?")="Enter a unique name up to 30 characters"
- +6 SET DIR("B")=""
- IF $GET(OLDNAME)'=""
- IF '$ORDER(IBE(357,"B",OLDNAME,0))
- SET DIR("B")=OLDNAME
- +7 FOR
- Begin DoDot:1
- +8 DO ^DIR
- IF $DATA(DIRUT)
- SET QUIT=1
- QUIT
- +9 IF $ORDER(^IBE(357,"B",Y,""))
- Begin DoDot:2
- +10 WRITE !,"The form name must be unique, try using the clinic in the name!"
- End DoDot:2
- +11 IF '$TEST
- SET NAME=Y
- SET QUIT=1
- End DoDot:1
- if QUIT
- QUIT
- +12 KILL DIR
- +13 QUIT NAME
- TKFORM() ;returns the form TOOL KIT that contains all of the tool kit blocs
- +1 NEW TKFORM,BLOCK,TKORDER,TK
- +2 SET TKFORM=+$ORDER(^IBE(357,"B","TOOL KIT",""))
- +3 IF 'TKFORM
- Begin DoDot:1
- +4 KILL DIC,DD,DO,DINUM
- SET DIC="^IBE(357,"
- SET DIC(0)=""
- SET X="TOOL KIT"
- +5 DO FILE^DICN
- KILL DIC,DIE,DA
- +6 SET TKFORM=$SELECT(+(Y>0):+Y,1:"")
- +7 if 'TKFORM
- QUIT
- +8 SET ^IBE(357,TKFORM,0)="TOOL KIT^^CONTAINS ALL OF THE TOOL KIT BLOCKS^^^^1"
- +9 KILL DIK
- SET DIK="^IBE(357,"
- SET DA=TKFORM
- DO IX1^DIK
- KILL DIK
- +10 SET TKORDER=0
- FOR
- SET TKORDER=$ORDER(^IBE(357.1,"D",TKORDER))
- if 'TKORDER
- QUIT
- SET BLOCK=0
- FOR
- SET BLOCK=$ORDER(^IBE(357.1,"D",TKORDER,BLOCK))
- if 'BLOCK
- QUIT
- Begin DoDot:2
- +11 SET TK=$PIECE($GET(^IBE(357.1,BLOCK,0)),"^",14)
- IF 'TK
- KILL ^IBE(357.1,"D",TKORDER,BLOCK)
- QUIT
- +12 SET FORM=$PIECE($GET(^IBE(357.1,BLOCK,0)),"^",2)
- IF FORM'=TKFORM
- KILL ^IBE(357.1,"C",FORM,BLOCK)
- SET $PIECE(^IBE(357.1,BLOCK,0),"^",2)=TKFORM
- KILL DIK
- SET DIK="^IBE(357.1,"
- SET DA=BLOCK
- SET DIK(1)=.02
- DO EN1^DIK
- KILL DIK
- End DoDot:2
- End DoDot:1
- +13 QUIT TKFORM
