IBDF2A2 ;ALB/CJM - ENCOUNTER FORM (IBDF2A continued);NOV 16,1992
;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997
;
WCMP ;write the compiled version
N SUB,ND,WIDTH,STRING,LINES,ROW,FNAME,TYPE,UNIT,TYPENODE,ND2,SLCTN
S SUB=0 F S SUB=$O(^IBE(357.1,IBBLK,"S",SUB)) Q:'SUB S ND=$G(^IBE(357.1,IBBLK,"S",SUB,0)) D DRWSTR^IBDFU(+$P(ND,"^"),+$P(ND,"^",2),$P(ND,"^",5,200),$P(ND,"^",3),$P(ND,"^",4))
S SUB=0 F S SUB=$O(^IBE(357.1,IBBLK,"V",SUB)) Q:'SUB S ND=$G(^IBE(357.1,IBBLK,"V",SUB,0)) D DRWVLINE^IBDFU(+$P(ND,"^"),+$P(ND,"^",2),+$P(ND,"^",3),$P(ND,"^",4))
;
;bubbles
S SUB=0 F S SUB=$O(^IBE(357.1,IBBLK,"B",SUB)) Q:'SUB D
.S ND=$G(^IBE(357.1,IBBLK,"B",SUB,0))
.S ND2=$G(^IBE(357.1,IBBLK,"B",SUB,2))
.S SLCTN=$P($G(ND),"^",14)
.S SUBHDR=$P($G(^IBE(357.1,IBBLK,"B",SUB,1)),"^") D
..D DRWBBL^IBDFM1(+$P(ND,"^"),+$P(ND,"^",2),+$P(ND,"^",3),$P(ND,"^",4),$P(ND,"^",5),$P(ND,"^",6),$P(ND,"^",7),$P(ND,"^",8),$P(ND,"^",9),$P(ND,"^",10),$P(ND,"^",11),$P(ND,"^",12),SUBHDR,$P(ND,"^",13),$G(ND2),$G(SLCTN))
;
;handprint
S SUB=0 F S SUB=$O(^IBE(357.1,IBBLK,"H",SUB)) Q:'SUB S ND=$G(^IBE(357.1,IBBLK,"H",SUB,0)) D
.D DRWHAND^IBDFM1(+ND,+$P(ND,"^",2),+$P(ND,"^",3),$P(ND,"^",4),$P(ND,"^",6),$P(ND,"^",7),$P(ND,"^",8),$P(ND,"^",9),$P(ND,"^",10),$P(ND,"^",12),$P(ND,"^",14),$P(ND,"^",15),$P(ND,"^",17))
Q
;
SAVE(ARRAY,VAR) ;saves one array to the string=VAR, pass by reference
N SUB,I
S I=1,SUB="" F S SUB=$O(ARRAY(SUB)) Q:SUB="" S $P(VAR,"^",I)=ARRAY(SUB),I=I+1
Q
RESTORE(ARRAY,VAR) ;restores the array from the string=VAR, pass by reference
N SUB,I
S I=1,SUB="" F S SUB=$O(ARRAY(SUB)) Q:SUB="" S ARRAY(SUB)=$P(VAR,"^",I),I=I+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF2A2 1684 printed Oct 16, 2024@18:51:59 Page 2
IBDF2A2 ;ALB/CJM - ENCOUNTER FORM (IBDF2A continued);NOV 16,1992
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997
+2 ;
WCMP ;write the compiled version
+1 NEW SUB,ND,WIDTH,STRING,LINES,ROW,FNAME,TYPE,UNIT,TYPENODE,ND2,SLCTN
+2 SET SUB=0
FOR
SET SUB=$ORDER(^IBE(357.1,IBBLK,"S",SUB))
if 'SUB
QUIT
SET ND=$GET(^IBE(357.1,IBBLK,"S",SUB,0))
DO DRWSTR^IBDFU(+$PIECE(ND,"^"),+$PIECE(ND,"^",2),$PIECE(ND,"^",5,200),$PIECE(ND,"^",3),$PIECE(ND,"^",4))
+3 SET SUB=0
FOR
SET SUB=$ORDER(^IBE(357.1,IBBLK,"V",SUB))
if 'SUB
QUIT
SET ND=$GET(^IBE(357.1,IBBLK,"V",SUB,0))
DO DRWVLINE^IBDFU(+$PIECE(ND,"^"),+$PIECE(ND,"^",2),+$PIECE(ND,"^",3),$PIECE(ND,"^",4))
+4 ;
+5 ;bubbles
+6 SET SUB=0
FOR
SET SUB=$ORDER(^IBE(357.1,IBBLK,"B",SUB))
if 'SUB
QUIT
Begin DoDot:1
+7 SET ND=$GET(^IBE(357.1,IBBLK,"B",SUB,0))
+8 SET ND2=$GET(^IBE(357.1,IBBLK,"B",SUB,2))
+9 SET SLCTN=$PIECE($GET(ND),"^",14)
+10 SET SUBHDR=$PIECE($GET(^IBE(357.1,IBBLK,"B",SUB,1)),"^")
Begin DoDot:2
+11 DO DRWBBL^IBDFM1(+$PIECE(ND,"^"),+$PIECE(ND,"^",2),+$PIECE(ND,"^",3),$PIECE(ND,"^",4),$PIECE(ND,"^",5),$PIECE(ND,"^",6),$PIECE(ND,"^",7),$PIECE(ND,"^",8),$PIECE(ND,"^",9),...
... $PIECE(ND,"^",10),$PIECE(ND,"^",11),$PIECE(ND,"^",12),SUBHDR,$PIECE(ND,"^",13),$GET(ND2),$GET(SLCTN))
End DoDot:2
End DoDot:1
+12 ;
+13 ;handprint
+14 SET SUB=0
FOR
SET SUB=$ORDER(^IBE(357.1,IBBLK,"H",SUB))
if 'SUB
QUIT
SET ND=$GET(^IBE(357.1,IBBLK,"H",SUB,0))
Begin DoDot:1
+15 DO DRWHAND^IBDFM1(+ND,+$PIECE(ND,"^",2),+$PIECE(ND,"^",3),$PIECE(ND,"^",4),$PIECE(ND,"^",6),$PIECE(ND,"^",7),$PIECE(ND,"^",8),$PIECE(ND,"^",9),$PIECE(ND,"^",10),$PIECE(ND,"^",12),$PIECE(ND,"^",14),$PIECE(ND,"^",15),$PIECE(ND,"^",17))
End DoDot:1
+16 QUIT
+17 ;
SAVE(ARRAY,VAR) ;saves one array to the string=VAR, pass by reference
+1 NEW SUB,I
+2 SET I=1
SET SUB=""
FOR
SET SUB=$ORDER(ARRAY(SUB))
if SUB=""
QUIT
SET $PIECE(VAR,"^",I)=ARRAY(SUB)
SET I=I+1
+3 QUIT
RESTORE(ARRAY,VAR) ;restores the array from the string=VAR, pass by reference
+1 NEW SUB,I
+2 SET I=1
SET SUB=""
FOR
SET SUB=$ORDER(ARRAY(SUB))
if SUB=""
QUIT
SET ARRAY(SUB)=$PIECE(VAR,"^",I)
SET I=I+1
+3 QUIT
