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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF9B1 4949 printed Apr 09, 2024@21:41:23 Page 2
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
