IBDF5D ;ALB/CJM - ENCOUNTER FORM - (copy page) ;12/12/94
;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
;
;
COPYPAGE ;
N FROMFORM,PAGE,TOLINE,NODE,ROW,COL,BEGIN,END,QUIT,BLOCK
D FULL^VALM1
S VALMBCK="R"
S FROMFORM=$$SLCTFORM^IBDFU4("") Q:'FROMFORM
Q:'$$FORMSIZE^IBDFU1C(.FROMFORM)
I FROMFORM("PAGES")=1 D
.S BEGIN=0,END=FROMFORM("PAGE_HT")-1
E D Q:QUIT
.S QUIT=0
.K DIR S DIR(0)="N^1:"_FROMFORM("PAGES")_":0",DIR("A")="Copy Page Number",DIR("B")=1,DIR("?")="Which page do you want to copy?" D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q
.S PAGE=Y I 'PAGE S QUIT=1 Q
.S BEGIN=((PAGE-1)*FROMFORM("PAGE_HT"))-1,END=(BEGIN+FROMFORM("PAGE_HT"))-1
K DIR S DIR(0)="N^1:"_IBFORM("HT")_":0",DIR("A")="Copy To Line Number",DIR("B")=($$CURY^IBDFU4)+1,DIR("?")="Beginning at what line should the page be pasted?" D ^DIR K DIR I 'X!$D(DIRUT) S QUIT=1 Q
I 'Y S QUIT=1 Q
S TOLINE=Y-1
S BLOCK=0
F S BLOCK=$O(^IBE(357.1,"C",FROMFORM,BLOCK)) Q:'BLOCK S NODE=$G(^IBE(357.1,BLOCK,0)) Q:NODE="" S ROW=$P(NODE,"^",4),COL=$P(NODE,"^",5) D
.N NEWBLOCK,IBDLST,IBDX,IBDCS,IBDX,IBDY
.I '(ROW>END),'(ROW<BEGIN) S NEWBLOCK=$$COPYBLK^IBDFU2(BLOCK,IBFORM,357.1,357.1,(ROW#FROMFORM("PAGE_HT"))+TOLINE,COL)
.;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)
D IDXFORM^IBDF5A()
Q
;
COPY ;ask user whether to copy a block or a page
S VALMBCK="R"
K DIR S DIR(0)="SB^P:PAGE COPY;B:BLOCK COPY;",DIR("A")="Copy an entire page or a single block?",DIR("?")="You can copy either a single block or an entire page."
D ^DIR K DIR I $D(DIRUT) Q
D:Y="P" COPYPAGE
D:Y="B" COPYBLK^IBDF5C
K DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF5D 2127 printed Dec 13, 2024@02:51:33 Page 2
IBDF5D ;ALB/CJM - ENCOUNTER FORM - (copy page) ;12/12/94
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
+2 ;
+3 ;
COPYPAGE ;
+1 NEW FROMFORM,PAGE,TOLINE,NODE,ROW,COL,BEGIN,END,QUIT,BLOCK
+2 DO FULL^VALM1
+3 SET VALMBCK="R"
+4 SET FROMFORM=$$SLCTFORM^IBDFU4("")
if 'FROMFORM
QUIT
+5 if '$$FORMSIZE^IBDFU1C(.FROMFORM)
QUIT
+6 IF FROMFORM("PAGES")=1
Begin DoDot:1
+7 SET BEGIN=0
SET END=FROMFORM("PAGE_HT")-1
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 SET QUIT=0
+10 KILL DIR
SET DIR(0)="N^1:"_FROMFORM("PAGES")_":0"
SET DIR("A")="Copy Page Number"
SET DIR("B")=1
SET DIR("?")="Which page do you want to copy?"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET QUIT=1
QUIT
+11 SET PAGE=Y
IF 'PAGE
SET QUIT=1
QUIT
+12 SET BEGIN=((PAGE-1)*FROMFORM("PAGE_HT"))-1
SET END=(BEGIN+FROMFORM("PAGE_HT"))-1
End DoDot:1
if QUIT
QUIT
+13 KILL DIR
SET DIR(0)="N^1:"_IBFORM("HT")_":0"
SET DIR("A")="Copy To Line Number"
SET DIR("B")=($$CURY^IBDFU4)+1
SET DIR("?")="Beginning at what line should the page be pasted?"
DO ^DIR
KILL DIR
IF 'X!$DATA(DIRUT)
SET QUIT=1
QUIT
+14 IF 'Y
SET QUIT=1
QUIT
+15 SET TOLINE=Y-1
+16 SET BLOCK=0
+17 FOR
SET BLOCK=$ORDER(^IBE(357.1,"C",FROMFORM,BLOCK))
if 'BLOCK
QUIT
SET NODE=$GET(^IBE(357.1,BLOCK,0))
if NODE=""
QUIT
SET ROW=$PIECE(NODE,"^",4)
SET COL=$PIECE(NODE,"^",5)
Begin DoDot:1
+18 NEW NEWBLOCK,IBDLST,IBDX,IBDCS,IBDX,IBDY
+19 IF '(ROW>END)
IF '(ROW<BEGIN)
SET NEWBLOCK=$$COPYBLK^IBDFU2(BLOCK,IBFORM,357.1,357.1,(ROW#FROMFORM("PAGE_HT"))+TOLINE,COL)
+20 ;Now check if new block contains any selection lists that specify ICD-9 or ICD-10
+21 ;if so, update history field at #357 .19 or .2 plus field .21
+22 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
+23 ;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
+24 ;Only log history fields if ICD-9 or ICD-10 codes are contained in block.
IF '$ORDER(^IBE(357.3,"C",IBDLST,""))
QUIT
+25 SET IBDY=$$CSUPD357^IBDUTICD(IBFORM,IBDCS,"",$$NOW^XLFDT(),DUZ)
End DoDot:3
End DoDot:2
End DoDot:1
+26 DO IDXFORM^IBDF5A()
+27 QUIT
+28 ;
COPY ;ask user whether to copy a block or a page
+1 SET VALMBCK="R"
+2 KILL DIR
SET DIR(0)="SB^P:PAGE COPY;B:BLOCK COPY;"
SET DIR("A")="Copy an entire page or a single block?"
SET DIR("?")="You can copy either a single block or an entire page."
+3 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT
+4 if Y="P"
DO COPYPAGE
+5 if Y="B"
DO COPYBLK^IBDF5C
+6 KILL DIR
+7 QUIT
