IBDF5B ;ALB/CJM - ENCOUNTER FORM (edit a form - CONTINUED) ;07/27/93
;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
;
;
EDITBLK ;allows the user to edit everything about the block
;allows user to discard or save changes to the block
;
;If IBBLK and IBBLK2 are used to point to two copies, one copy for editing and the other in case 'undo' is needed
;
N IBBLK,IBVALMBG,TOP1,TOP2,BOT1,BOT2,IBBLK2,IBTKODR,IBJUNK,IFSAVE,WDATA
;N IBMEMARY
;
S IBVALMBG=VALMBG
D FULL^VALM1
S IBBLK=$$SLCTBLK^IBDFU8(IBFORM,IOSL,"HEADER") ;select the block
I IBBLK D
.D KILL^IBDFUA
.S (IBBLK2,IBTKODR,IBJUNK)=""
.S WDATA=IBPRINT("WITH_DATA")
.D COPYBLK(IBBLK,.IBBLK2,.IBBLK,.IBTKODR,.IBJUNK) I 'IBBLK S IBBLK=IBBLK2,IBBLK2="" Q ;sets IBBLK to the work copy, IBBLK2 to the copy actually on the form
.D TOPNBOT^IBDFU5(IBBLK,.TOP1,.BOT1)
.D EN^VALM("IBDF FORM BLOCK EDIT") ;call list processor
.I IBBLK,IBBLK2 D
..S IFSAVE=$$ASKSAVE
..I IFSAVE D SAVECOPY(.IBBLK,.IBBLK2,IBTKODR) S IBBLK=IBBLK2,IBBLK2=""
..I 'IFSAVE D DLTCOPY(IBBLK) S IBBLK=IBBLK2,IBBLK2=""
..L -^IBE(357.1,IBBLK):1
.I '$G(IBFASTXT) D
..S VALMBG=IBVALMBG
..S IBPRINT("WITH_DATA")=WDATA
..D TOPNBOT^IBDFU5(IBBLK,.TOP2,.BOT2)
..S TOP1=$S(TOP1<TOP2:TOP1,1:TOP2),BOT1=$S(BOT1>BOT2:BOT1,1:BOT2)
..D IDXFORM^IBDF5A(TOP1,BOT1)
K ^TMP("IBDF DELETE SELECTION OPTION",$J),^TMP("IBDF DELETED ALL SELECTIONS",$J),^TMP("IBDF ADDSLCTN",$J)
S VALMBCK="R"
Q
DLTCOPY(WORKCOPY) ;deletes the block=WORKCOPY and unlocks it
D DLTBLK^IBDFU3(WORKCOPY,IBJUNK,357.1)
L -^IBE(357.1,WORKCOPY)
S WORKCOPY=""
Q
SAVECOPY(WORKCOPY,FORMCOPY,IBTKODR) ;deletes the block=FORMCOPY,adds WORKCOPY to IBFORM
;NOTE: upon completion WORKCOPY="",FORMCOPY points to what WORKCOPY initially did
N IBDN,IBDX,IBD9,IBD10,IBDBL
Q:('FORMCOPY)!('WORKCOPY) ;something wrong!
;
K DIE,DA,DR S DIE="^IBE(357.1,",DA=WORKCOPY,DR=".02////"_IBFORM
I IBTKODR S DR=DR_";.14////"_IBTKODR
D ^DIE K DIE,DR,DA
;
;In order to be able to update history, first check to see if there is any Selection List which is either ICD-9 or ICD-10
S (IBD9,IBD10)=0
;FORMCOPY at this time is actually the Work Copy block, WORKCOPY is the new block
;Check to see if any List contains ICD-9 or ICD-10 existed prior this change
S IBDN="" F S IBDN=$O(^IBE(357.2,"C",FORMCOPY,IBDN)) Q:IBDN="" S IBDX=$P($G(^IBE(357.2,IBDN,0)),U,11) I IBDX?1.N S IBDX=$E($P($G(^IBE(357.6,IBDX,0)),U,1),1,30) D
.I '$D(^TMP("IBDF DELETED ALL SELECTIONS",$J)),'$O(^IBE(357.3,"C",IBDN,"")) Q ;Only log history fields if ICD-9 or ICD-10 codes are contained in block.
.I IBDX="DG SELECT ICD-9 DIAGNOSIS CODE" S IBD9=1
.I IBDX="DG SELECT ICD-10 DIAGNOSIS COD" S IBD10=1
;
;Now check for any Data Fields with ICD-9 or ICD-10 inputs
S IBDN=0 F S IBDN=$O(^IBE(357.1,FORMCOPY,"B",IBDN)) Q:IBDN'?1.N D
.S IBDX=$P(^IBE(357.1,FORMCOPY,"B",IBDN,0),U,3) I IBDX?1.N S IBDX=$E($P($G(^IBE(357.6,IBDX,0)),U,1),1,30) D
..I IBDX="INPUT DIAGNOSIS CODE (ICD9)" S IBD9=1
..I IBDX="INPUT DIAGNOSIS CODE (ICD10)" S IBD10=1
;
D DLTBLK^IBDFU3(FORMCOPY,IBFORM,357.1)
D UNCMPL^IBDF19(IBFORM,0)
L -^IBE(357.1,FORMCOPY)
S FORMCOPY=WORKCOPY,WORKCOPY=""
;
;Check to see if any List contains ICD-9 or ICD-10 existed after the change
S IBDQUIT=0
S IBDN="" F S IBDN=$O(^IBE(357.2,"C",FORMCOPY,IBDN)) Q:IBDN=""!(IBDQUIT) S IBDX=$P($G(^IBE(357.2,IBDN,0)),U,11) I IBDX?1.N S IBDX=$E($P($G(^IBE(357.6,IBDX,0)),U,1),1,30) D
.I '$D(^TMP("IBDF DELETED ALL SELECTIONS",$J)),'$O(^IBE(357.3,"C",IBDN,"")) S IBDQUIT=1 Q ;Only log history fields if ICD-9 or ICD-10 codes are contained in block.
.I IBDX="DG SELECT ICD-9 DIAGNOSIS CODE" S IBD9=1
.I IBDX="DG SELECT ICD-10 DIAGNOSIS COD" S IBD10=1
;
Q:IBDQUIT ;Do not update history fields if ICD-9 or ICD-10 codes are not contained within the block.
;
;Now check for any Data Fields with ICD-9 or ICD-10 inputs
S IBDN=0 F S IBDN=$O(^IBE(357.1,FORMCOPY,"B",IBDN)) Q:IBDN'?1.N D
.S IBDX=$P(^IBE(357.1,FORMCOPY,"B",IBDN,0),U,3) I IBDX?1.N S IBDX=$E($P($G(^IBE(357.6,IBDX,0)),U,1),1,30) D
..I IBDX="INPUT DIAGNOSIS CODE (ICD9)" S IBD9=1
..I IBDX="INPUT DIAGNOSIS CODE (ICD10)" S IBD10=1
;
;Now update history if ICD-9 or ICD-10 was present before or after the change
N IBDX
I IBD9 S IBDX=$$CSUPD357^IBDUTICD(IBFORM,1,"",$$NOW^XLFDT(),DUZ)
I IBD10 S IBDX=$$CSUPD357^IBDUTICD(IBFORM,30,"",$$NOW^XLFDT(),DUZ)
Q
;
COPYBLK(IBBLK,FORMCOPY,WORKCOPY,IBTKODR,IBJUNK) ;copies the IBBLK to the WORKCOPY, then puts sets FORMCOPY=IBBLK
;IBJUNK set to the form="WORKCOPY", IBTKODR set to the original value of the field TOOL KIT ORDER
;
N NODE
S WORKCOPY=IBBLK,FORMCOPY=""
Q:'IBBLK ;no block to copy!
S NODE=$G(^IBE(357.1,IBBLK,0))
S IBTKODR=$P(NODE,"^",14)
;find the form=WORKCOPY, used as a work area
S IBJUNK=+$O(^IBE(357,"B","WORKCOPY",""))
;copy the block
S FORMCOPY=$$COPYBLK^IBDFU2(IBBLK,IBFORM,357.1,357.1)
I 'FORMCOPY W !,"Unable to edit the block!" D PAUSE^IBDFU5 S FORMCOPY=IBBLK Q
;
;make sure both copies are locked
;the working copy on IBJUNK is locked so that the option does cleanup knows which blocks are in current use - others on IBJUNK can be deleted
L +^IBE(357.1,FORMCOPY):1
L +^IBE(357.1,WORKCOPY):1
;
;mark the working copy as not being in the tk and not on IBFORM
K DIE,DA,DR S DIE="^IBE(357.1,",DA=WORKCOPY,DR=".02////"_IBJUNK_";.14////0"
D ^DIE K DIE,DR,DA
Q
;
ASKSAVE() ;asks the user if changes to the block should be saved
;returns 1 for yes, 0 for no
K DIR S DIR(0)="Y",DIR("A")="Save changes to the block",DIR("B")="YES"
D ^DIR K DIR
Q:$D(DIRUT) 0
Q Y
DECIDE ;allows user to either save or discard changes to the block being edited
N WHAT
;
S WHAT=$$DOWHAT
I WHAT="S" D
.D SAVECOPY(.IBBLK,.IBBLK2,IBTKODR),COPYBLK(IBBLK2,.IBBLK2,.IBBLK,.IBTKODR,.IBJUNK) S VALMBCK="" I 'IBBLK S IBBLK=IBBLK2,IBBLK2="" S VALMBCK="Q"
I WHAT="D" D
.D DLTCOPY(IBBLK) S IBBLK=IBBLK2,IBBLK2="" D COPYBLK(IBBLK,.IBBLK2,.IBBLK,.IBTKODR,.IBJUNK)
.I IBBLK S VALMBCK="R" D IDXBLOCK^IBDFU4
.I 'IBBLK S IBBLK=IBBLK2,IBBLK2="",VALMBCK="Q"
Q
;
DOWHAT() ;returns "D" for discard, "S" for save, "" for do nothing
K DIR S DIR(0)="SB^S:Save Changes;D:Discard Changes;",DIR("A")="Save or Discard the recent changes to the block?"
D ^DIR K DIR
Q:$D(DIRUT) ""
Q Y
;
PRINT ;prints the form
;
N QUIT S QUIT=0
S VALMBCK=""
I $G(IBBLK),'$G(IBTKBLK) D Q:QUIT
.W !,"Before printing the form any changes you have made must be saved.",!,"Is that okay?"
.K DIR S DIR(0)="Y" D ^DIR K DIR I 'Y!$D(DIRUT) S QUIT=1 QUIT
.D SAVECOPY(.IBBLK,.IBBLK2,IBTKODR),COPYBLK(IBBLK2,.IBBLK2,.IBBLK,.IBTKODR,.IBJUNK) S VALMBCK="" I 'IBBLK S IBBLK=IBBLK2,IBBLK2="" S VALMBCK="Q",QUIT=1
D:'QUIT PRINT^IBDF1C(.IBFORM)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF5B 6828 printed Apr 09, 2024@21:08:13 Page 2
IBDF5B ;ALB/CJM - ENCOUNTER FORM (edit a form - CONTINUED) ;07/27/93
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
+2 ;
+3 ;
EDITBLK ;allows the user to edit everything about the block
+1 ;allows user to discard or save changes to the block
+2 ;
+3 ;If IBBLK and IBBLK2 are used to point to two copies, one copy for editing and the other in case 'undo' is needed
+4 ;
+5 NEW IBBLK,IBVALMBG,TOP1,TOP2,BOT1,BOT2,IBBLK2,IBTKODR,IBJUNK,IFSAVE,WDATA
+6 ;N IBMEMARY
+7 ;
+8 SET IBVALMBG=VALMBG
+9 DO FULL^VALM1
+10 ;select the block
SET IBBLK=$$SLCTBLK^IBDFU8(IBFORM,IOSL,"HEADER")
+11 IF IBBLK
Begin DoDot:1
+12 DO KILL^IBDFUA
+13 SET (IBBLK2,IBTKODR,IBJUNK)=""
+14 SET WDATA=IBPRINT("WITH_DATA")
+15 ;sets IBBLK to the work copy, IBBLK2 to the copy actually on the form
DO COPYBLK(IBBLK,.IBBLK2,.IBBLK,.IBTKODR,.IBJUNK)
IF 'IBBLK
SET IBBLK=IBBLK2
SET IBBLK2=""
QUIT
+16 DO TOPNBOT^IBDFU5(IBBLK,.TOP1,.BOT1)
+17 ;call list processor
DO EN^VALM("IBDF FORM BLOCK EDIT")
+18 IF IBBLK
IF IBBLK2
Begin DoDot:2
+19 SET IFSAVE=$$ASKSAVE
+20 IF IFSAVE
DO SAVECOPY(.IBBLK,.IBBLK2,IBTKODR)
SET IBBLK=IBBLK2
SET IBBLK2=""
+21 IF 'IFSAVE
DO DLTCOPY(IBBLK)
SET IBBLK=IBBLK2
SET IBBLK2=""
+22 LOCK -^IBE(357.1,IBBLK):1
End DoDot:2
+23 IF '$GET(IBFASTXT)
Begin DoDot:2
+24 SET VALMBG=IBVALMBG
+25 SET IBPRINT("WITH_DATA")=WDATA
+26 DO TOPNBOT^IBDFU5(IBBLK,.TOP2,.BOT2)
+27 SET TOP1=$SELECT(TOP1<TOP2:TOP1,1:TOP2)
SET BOT1=$SELECT(BOT1>BOT2:BOT1,1:BOT2)
+28 DO IDXFORM^IBDF5A(TOP1,BOT1)
End DoDot:2
End DoDot:1
+29 KILL ^TMP("IBDF DELETE SELECTION OPTION",$JOB),^TMP("IBDF DELETED ALL SELECTIONS",$JOB),^TMP("IBDF ADDSLCTN",$JOB)
+30 SET VALMBCK="R"
+31 QUIT
DLTCOPY(WORKCOPY) ;deletes the block=WORKCOPY and unlocks it
+1 DO DLTBLK^IBDFU3(WORKCOPY,IBJUNK,357.1)
+2 LOCK -^IBE(357.1,WORKCOPY)
+3 SET WORKCOPY=""
+4 QUIT
SAVECOPY(WORKCOPY,FORMCOPY,IBTKODR) ;deletes the block=FORMCOPY,adds WORKCOPY to IBFORM
+1 ;NOTE: upon completion WORKCOPY="",FORMCOPY points to what WORKCOPY initially did
+2 NEW IBDN,IBDX,IBD9,IBD10,IBDBL
+3 ;something wrong!
if ('FORMCOPY)!('WORKCOPY)
QUIT
+4 ;
+5 KILL DIE,DA,DR
SET DIE="^IBE(357.1,"
SET DA=WORKCOPY
SET DR=".02////"_IBFORM
+6 IF IBTKODR
SET DR=DR_";.14////"_IBTKODR
+7 DO ^DIE
KILL DIE,DR,DA
+8 ;
+9 ;In order to be able to update history, first check to see if there is any Selection List which is either ICD-9 or ICD-10
+10 SET (IBD9,IBD10)=0
+11 ;FORMCOPY at this time is actually the Work Copy block, WORKCOPY is the new block
+12 ;Check to see if any List contains ICD-9 or ICD-10 existed prior this change
+13 SET IBDN=""
FOR
SET IBDN=$ORDER(^IBE(357.2,"C",FORMCOPY,IBDN))
if IBDN=""
QUIT
SET IBDX=$PIECE($GET(^IBE(357.2,IBDN,0)),U,11)
IF IBDX?1.N
SET IBDX=$EXTRACT($PIECE($GET(^IBE(357.6,IBDX,0)),U,1),1,30)
Begin DoDot:1
+14 ;Only log history fields if ICD-9 or ICD-10 codes are contained in block.
IF '$DATA(^TMP("IBDF DELETED ALL SELECTIONS",$JOB))
IF '$ORDER(^IBE(357.3,"C",IBDN,""))
QUIT
+15 IF IBDX="DG SELECT ICD-9 DIAGNOSIS CODE"
SET IBD9=1
+16 IF IBDX="DG SELECT ICD-10 DIAGNOSIS COD"
SET IBD10=1
End DoDot:1
+17 ;
+18 ;Now check for any Data Fields with ICD-9 or ICD-10 inputs
+19 SET IBDN=0
FOR
SET IBDN=$ORDER(^IBE(357.1,FORMCOPY,"B",IBDN))
if IBDN'?1.N
QUIT
Begin DoDot:1
+20 SET IBDX=$PIECE(^IBE(357.1,FORMCOPY,"B",IBDN,0),U,3)
IF IBDX?1.N
SET IBDX=$EXTRACT($PIECE($GET(^IBE(357.6,IBDX,0)),U,1),1,30)
Begin DoDot:2
+21 IF IBDX="INPUT DIAGNOSIS CODE (ICD9)"
SET IBD9=1
+22 IF IBDX="INPUT DIAGNOSIS CODE (ICD10)"
SET IBD10=1
End DoDot:2
End DoDot:1
+23 ;
+24 DO DLTBLK^IBDFU3(FORMCOPY,IBFORM,357.1)
+25 DO UNCMPL^IBDF19(IBFORM,0)
+26 LOCK -^IBE(357.1,FORMCOPY)
+27 SET FORMCOPY=WORKCOPY
SET WORKCOPY=""
+28 ;
+29 ;Check to see if any List contains ICD-9 or ICD-10 existed after the change
+30 SET IBDQUIT=0
+31 SET IBDN=""
FOR
SET IBDN=$ORDER(^IBE(357.2,"C",FORMCOPY,IBDN))
if IBDN=""!(IBDQUIT)
QUIT
SET IBDX=$PIECE($GET(^IBE(357.2,IBDN,0)),U,11)
IF IBDX?1.N
SET IBDX=$EXTRACT($PIECE($GET(^IBE(357.6,IBDX,0)),U,1),1,30)
Begin DoDot:1
+32 ;Only log history fields if ICD-9 or ICD-10 codes are contained in block.
IF '$DATA(^TMP("IBDF DELETED ALL SELECTIONS",$JOB))
IF '$ORDER(^IBE(357.3,"C",IBDN,""))
SET IBDQUIT=1
QUIT
+33 IF IBDX="DG SELECT ICD-9 DIAGNOSIS CODE"
SET IBD9=1
+34 IF IBDX="DG SELECT ICD-10 DIAGNOSIS COD"
SET IBD10=1
End DoDot:1
+35 ;
+36 ;Do not update history fields if ICD-9 or ICD-10 codes are not contained within the block.
if IBDQUIT
QUIT
+37 ;
+38 ;Now check for any Data Fields with ICD-9 or ICD-10 inputs
+39 SET IBDN=0
FOR
SET IBDN=$ORDER(^IBE(357.1,FORMCOPY,"B",IBDN))
if IBDN'?1.N
QUIT
Begin DoDot:1
+40 SET IBDX=$PIECE(^IBE(357.1,FORMCOPY,"B",IBDN,0),U,3)
IF IBDX?1.N
SET IBDX=$EXTRACT($PIECE($GET(^IBE(357.6,IBDX,0)),U,1),1,30)
Begin DoDot:2
+41 IF IBDX="INPUT DIAGNOSIS CODE (ICD9)"
SET IBD9=1
+42 IF IBDX="INPUT DIAGNOSIS CODE (ICD10)"
SET IBD10=1
End DoDot:2
End DoDot:1
+43 ;
+44 ;Now update history if ICD-9 or ICD-10 was present before or after the change
+45 NEW IBDX
+46 IF IBD9
SET IBDX=$$CSUPD357^IBDUTICD(IBFORM,1,"",$$NOW^XLFDT(),DUZ)
+47 IF IBD10
SET IBDX=$$CSUPD357^IBDUTICD(IBFORM,30,"",$$NOW^XLFDT(),DUZ)
+48 QUIT
+49 ;
COPYBLK(IBBLK,FORMCOPY,WORKCOPY,IBTKODR,IBJUNK) ;copies the IBBLK to the WORKCOPY, then puts sets FORMCOPY=IBBLK
+1 ;IBJUNK set to the form="WORKCOPY", IBTKODR set to the original value of the field TOOL KIT ORDER
+2 ;
+3 NEW NODE
+4 SET WORKCOPY=IBBLK
SET FORMCOPY=""
+5 ;no block to copy!
if 'IBBLK
QUIT
+6 SET NODE=$GET(^IBE(357.1,IBBLK,0))
+7 SET IBTKODR=$PIECE(NODE,"^",14)
+8 ;find the form=WORKCOPY, used as a work area
+9 SET IBJUNK=+$ORDER(^IBE(357,"B","WORKCOPY",""))
+10 ;copy the block
+11 SET FORMCOPY=$$COPYBLK^IBDFU2(IBBLK,IBFORM,357.1,357.1)
+12 IF 'FORMCOPY
WRITE !,"Unable to edit the block!"
DO PAUSE^IBDFU5
SET FORMCOPY=IBBLK
QUIT
+13 ;
+14 ;make sure both copies are locked
+15 ;the working copy on IBJUNK is locked so that the option does cleanup knows which blocks are in current use - others on IBJUNK can be deleted
+16 LOCK +^IBE(357.1,FORMCOPY):1
+17 LOCK +^IBE(357.1,WORKCOPY):1
+18 ;
+19 ;mark the working copy as not being in the tk and not on IBFORM
+20 KILL DIE,DA,DR
SET DIE="^IBE(357.1,"
SET DA=WORKCOPY
SET DR=".02////"_IBJUNK_";.14////0"
+21 DO ^DIE
KILL DIE,DR,DA
+22 QUIT
+23 ;
ASKSAVE() ;asks the user if changes to the block should be saved
+1 ;returns 1 for yes, 0 for no
+2 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Save changes to the block"
SET DIR("B")="YES"
+3 DO ^DIR
KILL DIR
+4 if $DATA(DIRUT)
QUIT 0
+5 QUIT Y
DECIDE ;allows user to either save or discard changes to the block being edited
+1 NEW WHAT
+2 ;
+3 SET WHAT=$$DOWHAT
+4 IF WHAT="S"
Begin DoDot:1
+5 DO SAVECOPY(.IBBLK,.IBBLK2,IBTKODR)
DO COPYBLK(IBBLK2,.IBBLK2,.IBBLK,.IBTKODR,.IBJUNK)
SET VALMBCK=""
IF 'IBBLK
SET IBBLK=IBBLK2
SET IBBLK2=""
SET VALMBCK="Q"
End DoDot:1
+6 IF WHAT="D"
Begin DoDot:1
+7 DO DLTCOPY(IBBLK)
SET IBBLK=IBBLK2
SET IBBLK2=""
DO COPYBLK(IBBLK,.IBBLK2,.IBBLK,.IBTKODR,.IBJUNK)
+8 IF IBBLK
SET VALMBCK="R"
DO IDXBLOCK^IBDFU4
+9 IF 'IBBLK
SET IBBLK=IBBLK2
SET IBBLK2=""
SET VALMBCK="Q"
End DoDot:1
+10 QUIT
+11 ;
DOWHAT() ;returns "D" for discard, "S" for save, "" for do nothing
+1 KILL DIR
SET DIR(0)="SB^S:Save Changes;D:Discard Changes;"
SET DIR("A")="Save or Discard the recent changes to the block?"
+2 DO ^DIR
KILL DIR
+3 if $DATA(DIRUT)
QUIT ""
+4 QUIT Y
+5 ;
PRINT ;prints the form
+1 ;
+2 NEW QUIT
SET QUIT=0
+3 SET VALMBCK=""
+4 IF $GET(IBBLK)
IF '$GET(IBTKBLK)
Begin DoDot:1
+5 WRITE !,"Before printing the form any changes you have made must be saved.",!,"Is that okay?"
+6 KILL DIR
SET DIR(0)="Y"
DO ^DIR
KILL DIR
IF 'Y!$DATA(DIRUT)
SET QUIT=1
QUIT
+7 DO SAVECOPY(.IBBLK,.IBBLK2,IBTKODR)
DO COPYBLK(IBBLK2,.IBBLK2,.IBBLK,.IBTKODR,.IBJUNK)
SET VALMBCK=""
IF 'IBBLK
SET IBBLK=IBBLK2
SET IBBLK2=""
SET VALMBCK="Q"
SET QUIT=1
End DoDot:1
if QUIT
QUIT
+8 if 'QUIT
DO PRINT^IBDF1C(.IBFORM)
+9 QUIT
