IBDF1B3 ;ALB/CJM - ENCOUNTER FORM - (lists data that did not fit on the encounter form);4/28/93
;;3.0;AUTOMATED INFO COLLECTION SYS;**39**;APR 24, 1997
OVERFLOW ;
;loops through @IBARRAY("OVERFLOW"), printing in list form all the data that did not fit
;
N IBBLK,FIELD,TYPE,ITEM,RTN,PAGE
Q:'$D(@IBARRAY("OVERFLOW"))
S PAGE=1
D HDR
S IBBLK="" F S IBBLK=$O(@IBARRAY("OVERFLOW")@(IBBLK)) Q:'IBBLK D
.Q:$$BLKDESCR^IBDFU1B(.IBBLK)
.D BLOCKBRK
.S FIELD="" F S FIELD=$O(@IBARRAY("OVERFLOW")@(IBBLK,FIELD)) Q:'FIELD D
..S TYPE="" F S TYPE=$O(@IBARRAY("OVERFLOW")@(IBBLK,FIELD,TYPE)) Q:TYPE="" D
...I TYPE="DYNAMIC LIST" D LIST Q
...D FIELD
D FOOTER
K @IBARRAY("OVERFLOW")
Q
HDR ;writes header to top of page
N HDR
S HDR="ADDITIONAL ENCOUNTER FORM DATA"
W !,?((IOM-$L(HDR))/2),HDR,?(IOM-10),"PAGE: ",PAGE,!
W !,"CLINIC: ",$P($G(^SC(IBCLINIC,0)),"^")
W !,"PATIENT: " I $G(DFN) W $P($G(^DPT(DFN,0)),"^")
W !,"FORM: ",$P($G(^IBE(357,IBFORM,0)),"^"),!
S PAGE=PAGE+1
Q
BLOCKBRK ;writes a line to the report with the block name
I $Y>(IOSL-3) W @IOF D HDR
W !!,"BLOCK: ",$P($G(^IBE(357.1,IBBLK,0)),"^")
Q
N FTR S FTR="END OF REPORT"
W !!!,?((IOM-$L(FTR))\2),FTR,@IOF
Q
FIELD ;displays the field (if list, displays all, if record, displays subfields)
N LASTITEM,RTN,LABEL,XLAB,YLAB,XIO,YIO,WIO,HIO,BLK,ITEM,PIECE,SPACING,DISPLAY,VALUE,FLDNAME,RTN,LIST,IFARY
;
Q:'$$FLDDESCR^IBDFU1A(FIELD) ;gets the field description
D RTNDSCR^IBDFU1B(.RTN) ;get the rtn used by the field
S IFARY=RTN("DATA_LOCATION")
W !
I RTN("DATATYPE")=5 D TXTPRINT Q ;wordprocessing fields treated differently
;now do other than wordprocessing
S LIST=$S((RTN("DATATYPE")=3)!(RTN("DATATYPE")=4):1,1:0)
I LIST,TYPE="CURRENT" S ITEM=$G(@IBARRAY("OVERFLOW")@(IBBLK,FIELD,TYPE))
I TYPE="NEXT",LIST D
.I $Y>(IOSL-5) W @IOF D HDR
.S ITEM=1 W !,?5,"**** LIST OF ",$E(RTN("NAME"),$F(RTN("NAME")," "),40)," ****" F D LISTVAL D Q:'ITEM
..I VALUE'="" D SUBFLDS W !
I TYPE="CURRENT" D
.W !,?5,"**** ",$E(RTN("NAME"),$F(RTN("NAME")," "),40)_$S(LIST:" (#"_ITEM_")",1:"")_" ****"
.I 'LIST D SNGLVAL
.I LIST D LISTVAL
.D SUBFLDS
Q
SUBFLDS ;process each subfield
N LAST,PVALUE
S LAST=$$SFLDDSCR^IBDFU1A(FIELD,0) Q:'LAST
F D S LAST=$$SFLDDSCR^IBDFU1A(FIELD,LAST) Q:'LAST
.I RTN("DATATYPE")=1!(RTN("DATATYPE")=3) S PIECE=1
.S PVALUE=$P($G(VALUE),"^",PIECE)
.;don't use the label appearing on the encounter form - it might be 'context sensitive' - use description form package interface file
.S LABEL=$$DATANAME^IBDFU1B(RTN,PIECE)
.I $Y>(IOSL-3) W @IOF D HDR
.W !,?5,LABEL_": ",PVALUE
Q
;
LIST ;displays the list
N RTN,LABEL,ITEM,PIECE,VALUE,LIST,IFARY,CNT
;
S LIST=FIELD
Q:$$LSTDESCR^IBDFU1(.LIST) ;gets the list description
S RTN=LIST("RTN")
D RTNDSCR^IBDFU1B(.RTN) ;get the PACKAGE INTERFACE used
S IFARY=RTN("DATA_LOCATION")
W !
;
D
.S CNT=0
.I $Y>(IOSL-5) W @IOF D HDR
.S ITEM=1 W !,?5,"**** LIST OF ",$E(RTN("NAME"),$F(RTN("NAME")," "),40)," ****" F D LISTVAL D Q:'ITEM
..; -- file overflow data if not re-printing & there is a form ID
..I '$G(REPRINT),($G(LIST("INPUT_RTN"))]""),$G(IBPFID) D
...S CNT=CNT+1
...S DIC="^IBD(357.96,IBPFID,2,",DIC(0)="L",DIC("P")=$P(^DD(357.96,2,0),"^",2),DA(1)=IBPFID,X=CNT,DLAYGO=357.96
...S DIC("DR")=".03////^S X=LIST(""INPUT_RTN"");.04////^S X=$P(VALUE,""^"");.06////^S X=""S""_LIST_""("";.08////^S X=$P(VALUE,""^"",2)"
...K DD,DO D FILE^DICN K DIC,DA,DLAYGO,DD,DO
..I VALUE'="" D SUBCOLS W !
Q
SUBCOLS ;process each subcolumn
N PVALUE,SUB,PIECE
F SUB=1:1:6 D
.Q:(LIST("SCTYPE",SUB)'=1)
.Q:'LIST("SCPIECE",SUB)
.S PIECE=LIST("SCPIECE",SUB)
.S PVALUE=$P($G(VALUE),"^",PIECE)
.;don't use the label appearing on the encounter form - it might be 'context sensitive' - use description form package interface file
.S LABEL=$$DATANAME^IBDFU1B(RTN,PIECE)
.I $Y>(IOSL-3) W @IOF D HDR
.W !,?5,LABEL_": ",PVALUE
Q
;
SNGLVAL ;output - VALUE
S VALUE=$G(@IFARY)
Q
LISTVAL ;input - ITEM=prior item processes, output - VALUE,ITEM=current item processed
;
S VALUE=$S(ITEM:$G(@IFARY@(ITEM)),1:"")
;increment ITEM to next item
S ITEM=$O(@IFARY@(ITEM))
Q
TXTPRINT ;for printing a word-processing field
N LINE,X,DIWL,DIWR,DIWF,LABEL
S LINE=0,DIWR=IOM-10,DIWL=0,DIWF=""
K ^UTILITY($J,"W",1)
F S LINE=$O(@IFARY@(LINE)) Q:'LINE S X=$G(@IFARY@(LINE,0)) I X'="" D ^DIWP
S LABEL=$E(RTN("NAME"),$F(RTN("NAME")," "),40)
I $Y>(IOSL-5) W @IOF D HDR
W !,?5,LABEL_": "
S X=0 F S X=$O(^UTILITY($J,"W",0,X)) Q:'X D
.I $Y>(IOSL-3) W @IOF D HDR
.W !,?10,$G(^UTILITY($J,"W",0,X,0))
K ^UTILITY($J,"W",1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF1B3 4718 printed Dec 13, 2024@02:51:08 Page 2
IBDF1B3 ;ALB/CJM - ENCOUNTER FORM - (lists data that did not fit on the encounter form);4/28/93
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**39**;APR 24, 1997
OVERFLOW ;
+1 ;loops through @IBARRAY("OVERFLOW"), printing in list form all the data that did not fit
+2 ;
+3 NEW IBBLK,FIELD,TYPE,ITEM,RTN,PAGE
+4 if '$DATA(@IBARRAY("OVERFLOW"))
QUIT
+5 SET PAGE=1
+6 DO HDR
+7 SET IBBLK=""
FOR
SET IBBLK=$ORDER(@IBARRAY("OVERFLOW")@(IBBLK))
if 'IBBLK
QUIT
Begin DoDot:1
+8 if $$BLKDESCR^IBDFU1B(.IBBLK)
QUIT
+9 DO BLOCKBRK
+10 SET FIELD=""
FOR
SET FIELD=$ORDER(@IBARRAY("OVERFLOW")@(IBBLK,FIELD))
if 'FIELD
QUIT
Begin DoDot:2
+11 SET TYPE=""
FOR
SET TYPE=$ORDER(@IBARRAY("OVERFLOW")@(IBBLK,FIELD,TYPE))
if TYPE=""
QUIT
Begin DoDot:3
+12 IF TYPE="DYNAMIC LIST"
DO LIST
QUIT
+13 DO FIELD
End DoDot:3
End DoDot:2
End DoDot:1
+14 DO FOOTER
+15 KILL @IBARRAY("OVERFLOW")
+16 QUIT
HDR ;writes header to top of page
+1 NEW HDR
+2 SET HDR="ADDITIONAL ENCOUNTER FORM DATA"
+3 WRITE !,?((IOM-$LENGTH(HDR))/2),HDR,?(IOM-10),"PAGE: ",PAGE,!
+4 WRITE !,"CLINIC: ",$PIECE($GET(^SC(IBCLINIC,0)),"^")
+5 WRITE !,"PATIENT: "
IF $GET(DFN)
WRITE $PIECE($GET(^DPT(DFN,0)),"^")
+6 WRITE !,"FORM: ",$PIECE($GET(^IBE(357,IBFORM,0)),"^"),!
+7 SET PAGE=PAGE+1
+8 QUIT
BLOCKBRK ;writes a line to the report with the block name
+1 IF $Y>(IOSL-3)
WRITE @IOF
DO HDR
+2 WRITE !!,"BLOCK: ",$PIECE($GET(^IBE(357.1,IBBLK,0)),"^")
+3 QUIT
+1 NEW FTR
SET FTR="END OF REPORT"
+2 WRITE !!!,?((IOM-$LENGTH(FTR))\2),FTR,@IOF
+3 QUIT
FIELD ;displays the field (if list, displays all, if record, displays subfields)
+1 NEW LASTITEM,RTN,LABEL,XLAB,YLAB,XIO,YIO,WIO,HIO,BLK,ITEM,PIECE,SPACING,DISPLAY,VALUE,FLDNAME,RTN,LIST,IFARY
+2 ;
+3 ;gets the field description
if '$$FLDDESCR^IBDFU1A(FIELD)
QUIT
+4 ;get the rtn used by the field
DO RTNDSCR^IBDFU1B(.RTN)
+5 SET IFARY=RTN("DATA_LOCATION")
+6 WRITE !
+7 ;wordprocessing fields treated differently
IF RTN("DATATYPE")=5
DO TXTPRINT
QUIT
+8 ;now do other than wordprocessing
+9 SET LIST=$SELECT((RTN("DATATYPE")=3)!(RTN("DATATYPE")=4):1,1:0)
+10 IF LIST
IF TYPE="CURRENT"
SET ITEM=$GET(@IBARRAY("OVERFLOW")@(IBBLK,FIELD,TYPE))
+11 IF TYPE="NEXT"
IF LIST
Begin DoDot:1
+12 IF $Y>(IOSL-5)
WRITE @IOF
DO HDR
+13 SET ITEM=1
WRITE !,?5,"**** LIST OF ",$EXTRACT(RTN("NAME"),$FIND(RTN("NAME")," "),40)," ****"
FOR
DO LISTVAL
Begin DoDot:2
+14 IF VALUE'=""
DO SUBFLDS
WRITE !
End DoDot:2
if 'ITEM
QUIT
End DoDot:1
+15 IF TYPE="CURRENT"
Begin DoDot:1
+16 WRITE !,?5,"**** ",$EXTRACT(RTN("NAME"),$FIND(RTN("NAME")," "),40)_$SELECT(LIST:" (#"_ITEM_")",1:"")_" ****"
+17 IF 'LIST
DO SNGLVAL
+18 IF LIST
DO LISTVAL
+19 DO SUBFLDS
End DoDot:1
+20 QUIT
SUBFLDS ;process each subfield
+1 NEW LAST,PVALUE
+2 SET LAST=$$SFLDDSCR^IBDFU1A(FIELD,0)
if 'LAST
QUIT
+3 FOR
Begin DoDot:1
+4 IF RTN("DATATYPE")=1!(RTN("DATATYPE")=3)
SET PIECE=1
+5 SET PVALUE=$PIECE($GET(VALUE),"^",PIECE)
+6 ;don't use the label appearing on the encounter form - it might be 'context sensitive' - use description form package interface file
+7 SET LABEL=$$DATANAME^IBDFU1B(RTN,PIECE)
+8 IF $Y>(IOSL-3)
WRITE @IOF
DO HDR
+9 WRITE !,?5,LABEL_": ",PVALUE
End DoDot:1
SET LAST=$$SFLDDSCR^IBDFU1A(FIELD,LAST)
if 'LAST
QUIT
+10 QUIT
+11 ;
LIST ;displays the list
+1 NEW RTN,LABEL,ITEM,PIECE,VALUE,LIST,IFARY,CNT
+2 ;
+3 SET LIST=FIELD
+4 ;gets the list description
if $$LSTDESCR^IBDFU1(.LIST)
QUIT
+5 SET RTN=LIST("RTN")
+6 ;get the PACKAGE INTERFACE used
DO RTNDSCR^IBDFU1B(.RTN)
+7 SET IFARY=RTN("DATA_LOCATION")
+8 WRITE !
+9 ;
+10 Begin DoDot:1
+11 SET CNT=0
+12 IF $Y>(IOSL-5)
WRITE @IOF
DO HDR
+13 SET ITEM=1
WRITE !,?5,"**** LIST OF ",$EXTRACT(RTN("NAME"),$FIND(RTN("NAME")," "),40)," ****"
FOR
DO LISTVAL
Begin DoDot:2
+14 ; -- file overflow data if not re-printing & there is a form ID
+15 IF '$GET(REPRINT)
IF ($GET(LIST("INPUT_RTN"))]"")
IF $GET(IBPFID)
Begin DoDot:3
+16 SET CNT=CNT+1
+17 SET DIC="^IBD(357.96,IBPFID,2,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(357.96,2,0),"^",2)
SET DA(1)=IBPFID
SET X=CNT
SET DLAYGO=357.96
+18 SET DIC("DR")=".03////^S X=LIST(""INPUT_RTN"");.04////^S X=$P(VALUE,""^"");.06////^S X=""S""_LIST_""("";.08////^S X=$P(VALUE,""^"",2)"
+19 KILL DD,DO
DO FILE^DICN
KILL DIC,DA,DLAYGO,DD,DO
End DoDot:3
+20 IF VALUE'=""
DO SUBCOLS
WRITE !
End DoDot:2
if 'ITEM
QUIT
End DoDot:1
+21 QUIT
SUBCOLS ;process each subcolumn
+1 NEW PVALUE,SUB,PIECE
+2 FOR SUB=1:1:6
Begin DoDot:1
+3 if (LIST("SCTYPE",SUB)'=1)
QUIT
+4 if 'LIST("SCPIECE",SUB)
QUIT
+5 SET PIECE=LIST("SCPIECE",SUB)
+6 SET PVALUE=$PIECE($GET(VALUE),"^",PIECE)
+7 ;don't use the label appearing on the encounter form - it might be 'context sensitive' - use description form package interface file
+8 SET LABEL=$$DATANAME^IBDFU1B(RTN,PIECE)
+9 IF $Y>(IOSL-3)
WRITE @IOF
DO HDR
+10 WRITE !,?5,LABEL_": ",PVALUE
End DoDot:1
+11 QUIT
+12 ;
SNGLVAL ;output - VALUE
+1 SET VALUE=$GET(@IFARY)
+2 QUIT
LISTVAL ;input - ITEM=prior item processes, output - VALUE,ITEM=current item processed
+1 ;
+2 SET VALUE=$SELECT(ITEM:$GET(@IFARY@(ITEM)),1:"")
+3 ;increment ITEM to next item
+4 SET ITEM=$ORDER(@IFARY@(ITEM))
+5 QUIT
TXTPRINT ;for printing a word-processing field
+1 NEW LINE,X,DIWL,DIWR,DIWF,LABEL
+2 SET LINE=0
SET DIWR=IOM-10
SET DIWL=0
SET DIWF=""
+3 KILL ^UTILITY($JOB,"W",1)
+4 FOR
SET LINE=$ORDER(@IFARY@(LINE))
if 'LINE
QUIT
SET X=$GET(@IFARY@(LINE,0))
IF X'=""
DO ^DIWP
+5 SET LABEL=$EXTRACT(RTN("NAME"),$FIND(RTN("NAME")," "),40)
+6 IF $Y>(IOSL-5)
WRITE @IOF
DO HDR
+7 WRITE !,?5,LABEL_": "
+8 SET X=0
FOR
SET X=$ORDER(^UTILITY($JOB,"W",0,X))
if 'X
QUIT
Begin DoDot:1
+9 IF $Y>(IOSL-3)
WRITE @IOF
DO HDR
+10 WRITE !,?10,$GET(^UTILITY($JOB,"W",0,X,0))
End DoDot:1
+11 KILL ^UTILITY($JOB,"W",1)
+12 QUIT
