IBDF5C ;ALB/CJM - ENCOUNTER FORM (creating a new block) ;03/22/93
;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
;
;
NEWBLOCK ;adds a new block, expects IBFORM to be defined
N IBBLK,TOP,BOT
S VALMBCK="R"
S IBBLK=$$CREATE()
I IBBLK D
.D TOPNBOT^IBDFU5(IBBLK,.TOP,.BOT)
.D IDXFORM^IBDF5A(TOP,BOT)
Q
CREATE() ;creates the new block and allows the user to edit it
;INPUTS: expects IBFORM to be defined
; expects IBTKBLK to be defined - IBTKBLK=1 means add to tk
;returns IBBLK
N NAME,IBBLK,NODE,IBDFDONE,IBBG,IBLFT,DLAYGO
S IBBG=1,IBLFT=5
S VALMBCK="R"
I '$G(IBTKBLK) S IBBG=+$G(VALMBG),IBLFT=+$G(VALMLFT)
S NAME=$$NEWNAME Q:NAME=-1 ""
K DIC,DIE,DD,DO,DINUM S DIC="^IBE(357.1,",DIC(0)="FL",X=NAME,DLAYGO=357.1
D FILE^DICN K DIC,DIE,DA
S IBBLK=+Y
I 'IBBLK D
.W !,"Unable to create a new block!" K DIC,DIE D PAUSE^IBDFU5
I IBBLK D
.;delete everything in the block - it should be empty
.D DLTCNTNT^IBDFU3(IBBLK,357.1)
.;set the current position of the block to the upper left-hand corner of the screen as the default
.S $P(^IBE(357.1,IBBLK,0),"^",4,5)=(IBBG-1)_"^"_(IBLFT-5)
.;now let the user edit the new block - header,name,outline,etc.
.K DIE,DA S DIE=357.1,DA=IBBLK,DR="[IBDF NEW EMPTY BLOCK]",DIE("NO^")="BACKOUTOK" D ^DIE K DIC,DIE,DR,DA
.I 'IBDFDONE S DIK="^IBE(357.1,",DA=IBBLK K DA(1) D ^DIK K DIK,DA Q
Q IBBLK
NEWNAME() ;
K DIR S DIR(0)="357.1,.01A",DIR("A")="New Block Name: ",DIR("B")=""
D ^DIR K DIR I $D(DIRUT) Q -1
Q Y
REDRAW ;redraws the ;entire form
S VALMBCK="R"
D UNCMPALL^IBDF19(IBFORM)
D IDXFORM^IBDF5A()
Q
COPYBLK ;copies a block from another form,whether in the toolkit or not, expects IBFORM=current work form to be defined
N IBBLK,TOP,BOT,NEWBLOCK,IBDLST,IBDCS,IBDX,IBDY
S IBBLK=$$SELECT2^IBDF13("")
I IBBLK S NEWBLOCK=$$COPYBLK^IBDFU2(IBBLK,IBFORM,357.1,357.1,$$CURY^IBDFU4,$$CURX^IBDFU4,0,"",1) I NEWBLOCK D
.D RE^VALM4
.D POS^IBDFU4(NEWBLOCK)
.D TOPNBOT^IBDFU5(NEWBLOCK,.TOP,.BOT)
.D IDXFORM^IBDF5A(TOP,BOT)
.;Now check if new block contains any selection lists that specify ICD-9 or ICD-10
.;if so, update history field at #357 .19 or .2 plus field .21
.S IBDLST=0 F S IBDLST=$O(^IBE(357.2,"C",NEWBLOCK,IBDLST)) Q:IBDLST="" S IBDX=$P(^IBE(357.2,IBDLST,0),U,11) D:IBDX?1.N
..S IBDCS=$P(^IBE(357.6,IBDX,0),U,22) D:IBDCS=1!(IBDCS=30) ;Coding System 1=ICD-9 30=ICD-10
...I '$O(^IBE(357.3,"C",IBDLST,"")) Q ;Only log history fields if ICD-9 or ICD-10 codes are contained in block.
...S IBDY=$$CSUPD357^IBDUTICD(IBFORM,IBDCS,"",$$NOW^XLFDT(),DUZ)
S VALMBCK="R"
Q
;
VIEW ;toggles between viewing form with data and without data
N STARTVAL
S STARTVAL=IBPRINT("WITH_DATA")
I 'IBPRINT("WITH_DATA") D
.D FULL^VALM1
.S DFN=$$PATIENT
.I DFN S IBPRINT("WITH_DATA")=1 I '$G(IBAPPT) D NOW^%DTC S IBAPPT=% K %,%H,%I,X
E I IBPRINT("WITH_DATA") S IBPRINT("WITH_DATA")=0
;
;this action could be called at the form level or the block level - action depends on which
I '$G(IBBLK) D
.I STARTVAL'=IBPRINT("WITH_DATA") D JUSTDATA^IBDF2A(IBPRINT("WITH_DATA")) K ^TMP("IB",$J,"INTERFACES")
I $G(IBBLK) D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
S VALMBCK="R"
Q
;
PATIENT() ;asks for a patient, returns the DFN
K DIR S DIR(0)="P^2:EM",DIR("A")="Test with what Patient"
D ^DIR K DIR I $D(DIRUT)!(+Y<1) Q 0
Q +Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF5C 3388 printed Nov 22, 2024@18:01:42 Page 2
IBDF5C ;ALB/CJM - ENCOUNTER FORM (creating a new block) ;03/22/93
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
+2 ;
+3 ;
NEWBLOCK ;adds a new block, expects IBFORM to be defined
+1 NEW IBBLK,TOP,BOT
+2 SET VALMBCK="R"
+3 SET IBBLK=$$CREATE()
+4 IF IBBLK
Begin DoDot:1
+5 DO TOPNBOT^IBDFU5(IBBLK,.TOP,.BOT)
+6 DO IDXFORM^IBDF5A(TOP,BOT)
End DoDot:1
+7 QUIT
CREATE() ;creates the new block and allows the user to edit it
+1 ;INPUTS: expects IBFORM to be defined
+2 ; expects IBTKBLK to be defined - IBTKBLK=1 means add to tk
+3 ;returns IBBLK
+4 NEW NAME,IBBLK,NODE,IBDFDONE,IBBG,IBLFT,DLAYGO
+5 SET IBBG=1
SET IBLFT=5
+6 SET VALMBCK="R"
+7 IF '$GET(IBTKBLK)
SET IBBG=+$GET(VALMBG)
SET IBLFT=+$GET(VALMLFT)
+8 SET NAME=$$NEWNAME
if NAME=-1
QUIT ""
+9 KILL DIC,DIE,DD,DO,DINUM
SET DIC="^IBE(357.1,"
SET DIC(0)="FL"
SET X=NAME
SET DLAYGO=357.1
+10 DO FILE^DICN
KILL DIC,DIE,DA
+11 SET IBBLK=+Y
+12 IF 'IBBLK
Begin DoDot:1
+13 WRITE !,"Unable to create a new block!"
KILL DIC,DIE
DO PAUSE^IBDFU5
End DoDot:1
+14 IF IBBLK
Begin DoDot:1
+15 ;delete everything in the block - it should be empty
+16 DO DLTCNTNT^IBDFU3(IBBLK,357.1)
+17 ;set the current position of the block to the upper left-hand corner of the screen as the default
+18 SET $PIECE(^IBE(357.1,IBBLK,0),"^",4,5)=(IBBG-1)_"^"_(IBLFT-5)
+19 ;now let the user edit the new block - header,name,outline,etc.
+20 KILL DIE,DA
SET DIE=357.1
SET DA=IBBLK
SET DR="[IBDF NEW EMPTY BLOCK]"
SET DIE("NO^")="BACKOUTOK"
DO ^DIE
KILL DIC,DIE,DR,DA
+21 IF 'IBDFDONE
SET DIK="^IBE(357.1,"
SET DA=IBBLK
KILL DA(1)
DO ^DIK
KILL DIK,DA
QUIT
End DoDot:1
+22 QUIT IBBLK
NEWNAME() ;
+1 KILL DIR
SET DIR(0)="357.1,.01A"
SET DIR("A")="New Block Name: "
SET DIR("B")=""
+2 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT -1
+3 QUIT Y
REDRAW ;redraws the ;entire form
+1 SET VALMBCK="R"
+2 DO UNCMPALL^IBDF19(IBFORM)
+3 DO IDXFORM^IBDF5A()
+4 QUIT
COPYBLK ;copies a block from another form,whether in the toolkit or not, expects IBFORM=current work form to be defined
+1 NEW IBBLK,TOP,BOT,NEWBLOCK,IBDLST,IBDCS,IBDX,IBDY
+2 SET IBBLK=$$SELECT2^IBDF13("")
+3 IF IBBLK
SET NEWBLOCK=$$COPYBLK^IBDFU2(IBBLK,IBFORM,357.1,357.1,$$CURY^IBDFU4,$$CURX^IBDFU4,0,"",1)
IF NEWBLOCK
Begin DoDot:1
+4 DO RE^VALM4
+5 DO POS^IBDFU4(NEWBLOCK)
+6 DO TOPNBOT^IBDFU5(NEWBLOCK,.TOP,.BOT)
+7 DO IDXFORM^IBDF5A(TOP,BOT)
+8 ;Now check if new block contains any selection lists that specify ICD-9 or ICD-10
+9 ;if so, update history field at #357 .19 or .2 plus field .21
+10 SET IBDLST=0
FOR
SET IBDLST=$ORDER(^IBE(357.2,"C",NEWBLOCK,IBDLST))
if IBDLST=""
QUIT
SET IBDX=$PIECE(^IBE(357.2,IBDLST,0),U,11)
if IBDX?1.N
Begin DoDot:2
+11 ;Coding System 1=ICD-9 30=ICD-10
SET IBDCS=$PIECE(^IBE(357.6,IBDX,0),U,22)
if IBDCS=1!(IBDCS=30)
Begin DoDot:3
+12 ;Only log history fields if ICD-9 or ICD-10 codes are contained in block.
IF '$ORDER(^IBE(357.3,"C",IBDLST,""))
QUIT
+13 SET IBDY=$$CSUPD357^IBDUTICD(IBFORM,IBDCS,"",$$NOW^XLFDT(),DUZ)
End DoDot:3
End DoDot:2
End DoDot:1
+14 SET VALMBCK="R"
+15 QUIT
+16 ;
VIEW ;toggles between viewing form with data and without data
+1 NEW STARTVAL
+2 SET STARTVAL=IBPRINT("WITH_DATA")
+3 IF 'IBPRINT("WITH_DATA")
Begin DoDot:1
+4 DO FULL^VALM1
+5 SET DFN=$$PATIENT
+6 IF DFN
SET IBPRINT("WITH_DATA")=1
IF '$GET(IBAPPT)
DO NOW^%DTC
SET IBAPPT=%
KILL %,%H,%I,X
End DoDot:1
+7 IF '$TEST
IF IBPRINT("WITH_DATA")
SET IBPRINT("WITH_DATA")=0
+8 ;
+9 ;this action could be called at the form level or the block level - action depends on which
+10 IF '$GET(IBBLK)
Begin DoDot:1
+11 IF STARTVAL'=IBPRINT("WITH_DATA")
DO JUSTDATA^IBDF2A(IBPRINT("WITH_DATA"))
KILL ^TMP("IB",$JOB,"INTERFACES")
End DoDot:1
+12 IF $GET(IBBLK)
DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
+13 SET VALMBCK="R"
+14 QUIT
+15 ;
PATIENT() ;asks for a patient, returns the DFN
+1 KILL DIR
SET DIR(0)="P^2:EM"
SET DIR("A")="Test with what Patient"
+2 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(+Y<1)
QUIT 0
+3 QUIT +Y
