IBDF1B3.m

IBDF1B3 ;ALB/CJM - ENCOUNTER FORM - (lists data that did not fit on the encounter form);4/28/93

 ;;3.0;AUTOMATED INFO COLLECTION SYS;;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

FOOTER ;

 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

 ..I '$G(REPRINT),($G(LIST("INPUT_RTN"))]"") 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

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;;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 

FOOTER    ;

 +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

 +15                   IF '$GET(REPRINT)

                           IF ($GET(LIST("INPUT_RTN"))]"")

                               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