- 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 Feb 19, 2025@00:17:58 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