IBDF9B1.m

IBDF9B1 ;ALB/CJM - ENCOUNTER FORM - (report data fields) ;APRIL 22,1993

 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997

 ;

REPORT ;

 N TOP,BOTTOM,LEFT,RIGHT,QUIT,SCRNSIZE

 S QUIT=0,SCRNSIZE=4

 D RANGE

 D:'QUIT SEARCH(TOP,BOTTOM,LEFT,RIGHT)

 Q

RANGE ;asks the user for the range - returns TOP,BOTTOM,LEFT,RIGHT

 N I,HT,WIDTH

 S HT=IBBLK("H"),WIDTH=IBBLK("W")

 K DIR

 ;get TOP

 S DIR("A")="What is the top-most row to report on?"

 S DIR(0)="N^1:"_HT_":0",DIR("B")=1

 D ^DIR K DIR I (Y=-1)!$D(DIRUT) S QUIT=1 Q

 S TOP=Y

 ;now get BOTTOM

 S DIR("A")="What is the bottom-most row to report on? (optional)",DIR("?",1)="Enter the lowest row that you want to report on.",DIR("?")="Enter nothing to report all data fields below the highest row that you specified."

 K DIR("B") ;S DIR("B")=HT

 S DIR(0)="NO^"_TOP_":"_HT_":0"

 D ^DIR K DIR I (Y=-1)!$D(DTOUT)!$D(DUOUT) S QUIT=1 Q

 S BOTTOM=Y

 ;get LEFT

 S DIR("A")="What is the left-most column to report on?"

 S DIR(0)="N^1:"_WIDTH_":0",DIR("B")=1

 D ^DIR K DIR I (Y=-1)!$D(DIRUT) S QUIT=1 Q

 S LEFT=Y

 ;now get RIGHT

 S DIR("A")="What is the right-most column to report on? (optional)"

 S DIR("?",1)="Enter the right-most column that you want to report on.",DIR("?")="Enter nothing to report all data fields to the right of the left-most column that you specified."

 K DIR("B") ;S DIR("B")=WIDTH

 S DIR(0)="NO^"_LEFT_":"_WIDTH_":0"

 D ^DIR K DIR I (Y=-1)!$D(DTOUT)!$D(DUOUT) S QUIT=1 Q

 S RIGHT=Y

 ;now change TOP,BOTTOM,LEFT,RIGHT to their internal values

 ;(BOTTOM or RIGHT)="" has special meaning - means shift without limit 

 S TOP=TOP-1,LEFT=LEFT-1

 S:BOTTOM>0 BOTTOM=BOTTOM-1

 S:RIGHT>0 RIGHT=RIGHT-1

 Q

SEARCH(TOP,BOTTOM,LEFT,RIGHT) ;searches for data fields in IBBLK falling within the rectangle defined by TOP,BOTTOM,LEFT,RIGHT and reports on them

 N SUBFLD,IBX,IBY,FLD,QUIT,ARY,RTN,WP,LIST,CNT,NODE,COUNT

 S ARY="^TMP(""IBDF"",$J,""LIST OF DATA FIELDS"")"

 K @ARY

 S (COUNT,QUIT)=0

 S FLD="" F  S FLD=$O(^IBE(357.5,"C",IBBLK,FLD)) Q:QUIT!('FLD)  D

 .S FLD("NODE0")=$G(^IBE(357.5,FLD,0))

 .Q:FLD("NODE0")=""

 .S FLD("NAME")=$P(FLD("NODE0"),"^")

 .S FLD("MULTIPLE SF")="NO"

 .S (SUBFLD,CNT)=0 F  S SUBFLD=$O(^IBE(357.5,FLD,2,SUBFLD)) Q:'SUBFLD  S NODE=$G(^IBE(357.5,FLD,2,SUBFLD,0)) I $P(NODE,"^",9),$P(NODE,"^",8) S CNT=CNT+1 I CNT>1 S FLD("MULTIPLE SF")="YES" Q

 .Q:$P(FLD("NODE0"),"^",2)'=IBBLK

 .D RTNDESCR

 .I WP S IBX=+$P(FLD("NODE0"),"^",10),IBY=+$P(FLD("NODE0"),"^",11) D:$$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT)  Q

 ..S FLD("MULTIPLE SF")="NO"

 ..D SETARY

 .S SUBFLD=0 F  S SUBFLD=$O(^IBE(357.5,FLD,2,SUBFLD)) Q:QUIT!('SUBFLD)  D

 ..S SUBFLD("NODE0")=$G(^IBE(357.5,FLD,2,SUBFLD,0)) Q:SUBFLD("NODE0")=""

 ..S IBX=$P(SUBFLD("NODE0"),"^",7),IBY=$P(SUBFLD("NODE0"),"^",6) I IBX]"",IBY]"" I $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D SETARY

 D PRINT

 K @ARY

 Q

RTNDESCR ;sets RTN=package interface and gets fields needed from the 0 node, sets the flags LIST, &  WP

 S RTN=$P(FLD("NODE0"),"^",3)

 I 'RTN S (WP,RTN("INTERFACE"),RTN("PRINT COMPLETE"),LIST,RTN("NODE0"))=0 Q

 S RTN("NODE0")=$G(^IBE(357.6,RTN,0))

 S LIST=$S("34"[$P(RTN("NODE0"),"^",7):1,1:0)

 S WP=$S($P(RTN("NODE0"),"^",7)=5:1,1:0)

 S RTN("INTERFACE")=$P(RTN("NODE0"),"^"),RTN("INTERFACE")=$E(RTN("INTERFACE"),$F(RTN("INTERFACE")," "),40)

 S RTN("PRINT COMPLETE")=$S($P(RTN("NODE0"),"^",8):"Y",1:"N")

 Q

PRINT ;prints @ARY

 N CNT,LINE S (QUIT,CNT)=0

 S COUNT=0 F  S COUNT=$O(@ARY@(COUNT)) Q:QUIT!('COUNT)  S IBY="" F  S IBY=$O(@ARY@(COUNT,IBY)) Q:QUIT!(IBY="")  D

 .S IBX="" F  S IBX=$O(@ARY@(COUNT,IBY,IBX)) Q:QUIT!(IBX="")  D

 ..S LINE=0 F  S LINE=$O(@ARY@(COUNT,IBY,IBX,LINE)) Q:'LINE  W !,$E($G(@ARY@(COUNT,IBY,IBX,LINE)),1,IOM) S CNT=LINE

 ..F  Q:(CNT>SCRNSIZE)  W ! S CNT=CNT+1

 ..S QUIT=$$PAUSE

 Q

PAUSE() ;pauses after each field discription is displayed

 N ANS

 R ANS:DTIME

 Q $S('$T:1,ANS["^":1,1:0)

SETARY ;writes data field description to @ARY

 N PIECE,DATA,LINE

 S COUNT=COUNT+1

 S @ARY@(COUNT,IBY,IBX,1)="Name of Data Field: "_FLD("NAME")_"     Multiple Subfields With Data: "_FLD("MULTIPLE SF")

 S LINE="Row: "_(IBY+1)_"  Column: "_(IBX+1)_"  Length: "_$S(WP:$P(FLD("NODE0"),"^",14)_"    Lines Allocated On Form: "_$P(FLD("NODE0"),"^",12),1:$P(SUBFLD("NODE0"),"^",8))

 S @ARY@(COUNT,IBY,IBX,2)=LINE_$S(LIST:"  Number On List: "_$P(FLD("NODE0"),"^",5)_"  Last On List To Print?: "_$S($P(FLD("NODE0"),"^",4):"Y",1:"N"),1:"")

 S @ARY@(COUNT,IBY,IBX,3)="Package Interface: "_RTN("INTERFACE")_"     Print Overflowed Data?: "_RTN("PRINT COMPLETE")

 I 'WP S DATA="",PIECE=$P(SUBFLD("NODE0"),"^",9) S:'PIECE PIECE=1 S:RTN DATA=$$DATANAME^IBDFU1B(RTN,PIECE) D

 .S @ARY@(COUNT,IBY,IBX,4)="Label"_$S($P(SUBFLD("NODE0"),"^",3)["I":" (not displayed): ",1:": ")_$P(SUBFLD("NODE0"),"^")_"   Data: "_DATA

 I WP,RTN S @ARY@(COUNT,IBY,IBX,4)=$G(^IBE(357.6,RTN,1,1,0)),@ARY@(COUNT,IBY,IBX,5)=$G(^IBE(357.6,RTN,1,2,0))

 Q

IBDF9B1   ;ALB/CJM - ENCOUNTER FORM - (report data fields) ;APRIL 22,1993

 +1       ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997

 +2       ;

REPORT    ;

 +1        NEW TOP,BOTTOM,LEFT,RIGHT,QUIT,SCRNSIZE

 +2        SET QUIT=0

           SET SCRNSIZE=4

 +3        DO RANGE

 +4        IF 'QUIT

               DO SEARCH(TOP,BOTTOM,LEFT,RIGHT)

 +5        QUIT 

RANGE     ;asks the user for the range - returns TOP,BOTTOM,LEFT,RIGHT

 +1        NEW I,HT,WIDTH

 +2        SET HT=IBBLK("H")

           SET WIDTH=IBBLK("W")

 +3        KILL DIR

 +4       ;get TOP

 +5        SET DIR("A")="What is the top-most row to report on?"

 +6        SET DIR(0)="N^1:"_HT_":0"

           SET DIR("B")=1

 +7        DO ^DIR

           KILL DIR

           IF (Y=-1)!$DATA(DIRUT)

               SET QUIT=1

               QUIT 

 +8        SET TOP=Y

 +9       ;now get BOTTOM

 +10       SET DIR("A")="What is the bottom-most row to report on? (optional)"

           SET DIR("?",1)="Enter the lowest row that you want to report on."

           SET DIR("?")="Enter nothing to report all data fields below the highest row that you specified."

 +11      ;S DIR("B")=HT

           KILL DIR("B")

 +12       SET DIR(0)="NO^"_TOP_":"_HT_":0"

 +13       DO ^DIR

           KILL DIR

           IF (Y=-1)!$DATA(DTOUT)!$DATA(DUOUT)

               SET QUIT=1

               QUIT 

 +14       SET BOTTOM=Y

 +15      ;get LEFT

 +16       SET DIR("A")="What is the left-most column to report on?"

 +17       SET DIR(0)="N^1:"_WIDTH_":0"

           SET DIR("B")=1

 +18       DO ^DIR

           KILL DIR

           IF (Y=-1)!$DATA(DIRUT)

               SET QUIT=1

               QUIT 

 +19       SET LEFT=Y

 +20      ;now get RIGHT

 +21       SET DIR("A")="What is the right-most column to report on? (optional)"

 +22       SET DIR("?",1)="Enter the right-most column that you want to report on."

           SET DIR("?")="Enter nothing to report all data fields to the right of the left-most column that you specified."

 +23      ;S DIR("B")=WIDTH

           KILL DIR("B")

 +24       SET DIR(0)="NO^"_LEFT_":"_WIDTH_":0"

 +25       DO ^DIR

           KILL DIR

           IF (Y=-1)!$DATA(DTOUT)!$DATA(DUOUT)

               SET QUIT=1

               QUIT 

 +26       SET RIGHT=Y

 +27      ;now change TOP,BOTTOM,LEFT,RIGHT to their internal values

 +28      ;(BOTTOM or RIGHT)="" has special meaning - means shift without limit 

 +29       SET TOP=TOP-1

           SET LEFT=LEFT-1

 +30       IF BOTTOM>0

               SET BOTTOM=BOTTOM-1

 +31       IF RIGHT>0

               SET RIGHT=RIGHT-1

 +32       QUIT 

SEARCH(TOP,BOTTOM,LEFT,RIGHT) ;searches for data fields in IBBLK falling within the rectangle defined by TOP,BOTTOM,LEFT,RIGHT and reports on them

 +1        NEW SUBFLD,IBX,IBY,FLD,QUIT,ARY,RTN,WP,LIST,CNT,NODE,COUNT

 +2        SET ARY="^TMP(""IBDF"",$J,""LIST OF DATA FIELDS"")"

 +3        KILL @ARY

 +4        SET (COUNT,QUIT)=0

 +5        SET FLD=""

           FOR 

               SET FLD=$ORDER(^IBE(357.5,"C",IBBLK,FLD))

               IF QUIT!('FLD)

                   QUIT 

               Begin DoDot:1

 +6                SET FLD("NODE0")=$GET(^IBE(357.5,FLD,0))

 +7                IF FLD("NODE0")=""

                       QUIT 

 +8                SET FLD("NAME")=$PIECE(FLD("NODE0"),"^")

 +9                SET FLD("MULTIPLE SF")="NO"

 +10               SET (SUBFLD,CNT)=0

                   FOR 

                       SET SUBFLD=$ORDER(^IBE(357.5,FLD,2,SUBFLD))

                       IF 'SUBFLD

                           QUIT 

                       SET NODE=$GET(^IBE(357.5,FLD,2,SUBFLD,0))

                       IF $PIECE(NODE,"^",9)

                           IF $PIECE(NODE,"^",8)

                               SET CNT=CNT+1

                               IF CNT>1

                                   SET FLD("MULTIPLE SF")="YES"

                                   QUIT 

 +11               IF $PIECE(FLD("NODE0"),"^",2)'=IBBLK

                       QUIT 

 +12               DO RTNDESCR

 +13               IF WP

                       SET IBX=+$PIECE(FLD("NODE0"),"^",10)

                       SET IBY=+$PIECE(FLD("NODE0"),"^",11)

                       IF $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT)

                           Begin DoDot:2

 +14                           SET FLD("MULTIPLE SF")="NO"

 +15                           DO SETARY

                           End DoDot:2

                       QUIT 

 +16               SET SUBFLD=0

                   FOR 

                       SET SUBFLD=$ORDER(^IBE(357.5,FLD,2,SUBFLD))

                       IF QUIT!('SUBFLD)

                           QUIT 

                       Begin DoDot:2

 +17                       SET SUBFLD("NODE0")=$GET(^IBE(357.5,FLD,2,SUBFLD,0))

                           IF SUBFLD("NODE0")=""

                               QUIT 

 +18                       SET IBX=$PIECE(SUBFLD("NODE0"),"^",7)

                           SET IBY=$PIECE(SUBFLD("NODE0"),"^",6)

                           IF IBX]""

                               IF IBY]""

                                   IF $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT)

                                       DO SETARY

                       End DoDot:2

               End DoDot:1

 +19       DO PRINT

 +20       KILL @ARY

 +21       QUIT 

RTNDESCR  ;sets RTN=package interface and gets fields needed from the 0 node, sets the flags LIST, &  WP

 +1        SET RTN=$PIECE(FLD("NODE0"),"^",3)

 +2        IF 'RTN

               SET (WP,RTN("INTERFACE"),RTN("PRINT COMPLETE"),LIST,RTN("NODE0"))=0

               QUIT 

 +3        SET RTN("NODE0")=$GET(^IBE(357.6,RTN,0))

 +4        SET LIST=$SELECT("34"[$PIECE(RTN("NODE0"),"^",7):1,1:0)

 +5        SET WP=$SELECT($PIECE(RTN("NODE0"),"^",7)=5:1,1:0)

 +6        SET RTN("INTERFACE")=$PIECE(RTN("NODE0"),"^")

           SET RTN("INTERFACE")=$EXTRACT(RTN("INTERFACE"),$FIND(RTN("INTERFACE")," "),40)

 +7        SET RTN("PRINT COMPLETE")=$SELECT($PIECE(RTN("NODE0"),"^",8):"Y",1:"N")

 +8        QUIT 

PRINT     ;prints @ARY

 +1        NEW CNT,LINE

           SET (QUIT,CNT)=0

 +2        SET COUNT=0

           FOR 

               SET COUNT=$ORDER(@ARY@(COUNT))

               IF QUIT!('COUNT)

                   QUIT 

               SET IBY=""

               FOR 

                   SET IBY=$ORDER(@ARY@(COUNT,IBY))

                   IF QUIT!(IBY="")

                       QUIT 

                   Begin DoDot:1

 +3                    SET IBX=""

                       FOR 

                           SET IBX=$ORDER(@ARY@(COUNT,IBY,IBX))

                           IF QUIT!(IBX="")

                               QUIT 

                           Begin DoDot:2

 +4                            SET LINE=0

                               FOR 

                                   SET LINE=$ORDER(@ARY@(COUNT,IBY,IBX,LINE))

                                   IF 'LINE

                                       QUIT 

                                   WRITE !,$EXTRACT($GET(@ARY@(COUNT,IBY,IBX,LINE)),1,IOM)

                                   SET CNT=LINE

 +5                            FOR 

                                   IF (CNT>SCRNSIZE)

                                       QUIT 

                                   WRITE !

                                   SET CNT=CNT+1

 +6                            SET QUIT=$$PAUSE

                           End DoDot:2

                   End DoDot:1

 +7        QUIT 

PAUSE()   ;pauses after each field discription is displayed

 +1        NEW ANS

 +2        READ ANS:DTIME

 +3        QUIT $SELECT('$TEST:1,ANS["^":1,1:0)

SETARY    ;writes data field description to @ARY

 +1        NEW PIECE,DATA,LINE

 +2        SET COUNT=COUNT+1

 +3        SET @ARY@(COUNT,IBY,IBX,1)="Name of Data Field: "_FLD("NAME")_"     Multiple Subfields With Data: "_FLD("MULTIPLE SF")

 +4        SET LINE="Row: "_(IBY+1)_"  Column: "_(IBX+1)_"  Length: "_$SELECT(WP:$PIECE(FLD("NODE0"),"^",14)_"    Lines Allocated On Form: "_$PIECE(FLD("NODE0"),"^",12),1:$PIECE(SUBFLD("NODE0"),"^",8))

 +5        SET @ARY@(COUNT,IBY,IBX,2)=LINE_$SELECT(LIST:"  Number On List: "_$PIECE(FLD("NODE0"),"^",5)_"  Last On List To Print?: "_$SELECT($PIECE(FLD("NODE0"),"^",4):"Y",1:"N"),1:"")

 +6        SET @ARY@(COUNT,IBY,IBX,3)="Package Interface: "_RTN("INTERFACE")_"     Print Overflowed Data?: "_RTN("PRINT COMPLETE")

 +7        IF 'WP

               SET DATA=""

               SET PIECE=$PIECE(SUBFLD("NODE0"),"^",9)

               IF 'PIECE

                   SET PIECE=1

               IF RTN

                   SET DATA=$$DATANAME^IBDFU1B(RTN,PIECE)

               Begin DoDot:1

 +8                SET @ARY@(COUNT,IBY,IBX,4)="Label"_$SELECT($PIECE(SUBFLD("NODE0"),"^",3)["I":" (not displayed): ",1:": ")_$PIECE(SUBFLD("NODE0"),"^")_"   Data: "_DATA

               End DoDot:1

 +9        IF WP

               IF RTN

                   SET @ARY@(COUNT,IBY,IBX,4)=$GET(^IBE(357.6,RTN,1,1,0))

                   SET @ARY@(COUNT,IBY,IBX,5)=$GET(^IBE(357.6,RTN,1,2,0))

 +10       QUIT