- 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 Jan 18, 2025@03:52:24 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