- ACHSA2 ; IHS/ITSC/PMF - ENTER DOCUMENTS (3/8)-(BLANKET DESCRIPTION) ; [ 10/16/2001 8:16 AM ]
- ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
- ;
- A1 ;
- K A
- S ACHSBLT=$G(ACHSBLT)
- I ACHSBLT]"" W !!?9,"Blanket Description" G E1
- W !!,"Blanket Description: "
- D READ^ACHSFU
- G END:$G(ACHSQUIT),Q1:Y?1"?".E
- I Y="" W *7,!!," The Description Is Required To Complete This Document" G A1
- S ACHSBLT=Y
- E1 ;
- K A
- S C=0,J=99
- F I=1:1 S Y=$P(ACHSBLT," ",I) Q:Y="" S:($L(Y)+J>37) C=C+1,A(C)="",J=0 S:A(C)]"" A(C)=A(C)_" ",J=J+1 S A(C)=A(C)_Y,J=J+$L(Y)
- W !!
- F I=1:1 Q:'$D(A(I)) W !,"Line ",I,": ",A(I)
- S L=I-1
- E2 ;
- W !!,"Edit Line #: "
- D READ^ACHSFU
- G END:$G(ACHSQUIT)
- I Y?1"?".E W !," Enter The Number Of The Line You Wish To Edit",!," Select 1 to ",L G E2
- G E9:Y=""
- I +Y'=Y!(Y<1)!(Y>L) W *7," ??" G E2
- S X=A(Y),N=Y
- E3 ;
- W !,X,!," Replace: "
- D READ^ACHSFU
- G E1:$D(DUOUT),END:$G(ACHSQUIT),Q2:Y?1"?".E
- I Y="END" S P=$C(1) G E6
- G E7:Y=""
- D SB1
- I P="" W *7," ??" G E3
- E6 ;
- W:$X>60 !
- W " With: "
- D READ^ACHSFU
- G E1:$D(DUOUT),END:$G(ACHSQUIT)
- I Y?1"?".E W !," Enter The New Characters or 'RETURN' If None" G E6
- S X=$P(X,P)_Y_$P(X,P,2,999)
- G E3:X]"",E7
- E7 ;
- S ACHSBLT="",L=0,A(N)=X
- F I=1:1 Q:'$D(A(I)) I A(I)]"" S L=L+$L(A(I)) G E8:L>150 S:ACHSBLT]"" ACHSBLT=ACHSBLT_" " S ACHSBLT=ACHSBLT_A(I)
- G E1
- ;
- E8 ;
- S ACHSBLT=ACHSBLT_$S(ACHSBLT="":"",1:" ")_$E(A(I),1,150-$L(ACHSBLT))
- W *7,!," Too Long... (150 Character Max.)"
- G E1
- ;
- E9 ;
- K:ACHSBLT="" ACHSBLT
- END ;
- K A,B,C,E,F,I,J,L,N,P,R,S,W,X
- Q
- ;
- SB1 ;
- S F=$L(Y,"..."),(P,S)=""
- Q:F>2
- S R=$P(Y,"..."),E=$F(X,R)
- Q:'E
- S E=E-1
- S B=E-$L(R)+1
- I F>1 S Y=$P(Y,"...",2) S:Y="" E=999 I Y]"" S W=$F(X,Y,E+1) Q:'W S E=W-1
- S P=$E(X,B,E)
- Q
- ;
- Q1 ;
- W !!," Enter A Description For This Document.",!," It Will Be Printed In Place Of The",!," Patient Identification Data On The Form."
- W !!," The Maximun Length Allowed Is 150 Characters.",!," Type The Description In Single Stream Of Characters",!," (ie. Don't Press The Return Key Until The End)."
- G A1
- ;
- Q2 ;
- W !!," Enter The Characters You Wish To Delete.",!," Then You Will Be Asked To Enter The Characters To",!," Replace The Just Deleted Characters, If any.",!
- G E3
- ;
- ACHSA2 ; IHS/ITSC/PMF - ENTER DOCUMENTS (3/8)-(BLANKET DESCRIPTION) ; [ 10/16/2001 8:16 AM ]
- +1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
- +2 ;
- A1 ;
- +1 KILL A
- +2 SET ACHSBLT=$GET(ACHSBLT)
- +3 IF ACHSBLT]""
- WRITE !!?9,"Blanket Description"
- GOTO E1
- +4 WRITE !!,"Blanket Description: "
- +5 DO READ^ACHSFU
- +6 IF $GET(ACHSQUIT)
- GOTO END
- IF Y?1"?".E
- GOTO Q1
- +7 IF Y=""
- WRITE *7,!!," The Description Is Required To Complete This Document"
- GOTO A1
- +8 SET ACHSBLT=Y
- E1 ;
- +1 KILL A
- +2 SET C=0
- SET J=99
- +3 FOR I=1:1
- SET Y=$PIECE(ACHSBLT," ",I)
- IF Y=""
- QUIT
- IF ($LENGTH(Y)+J>37)
- SET C=C+1
- SET A(C)=""
- SET J=0
- IF A(C)]""
- SET A(C)=A(C)_" "
- SET J=J+1
- SET A(C)=A(C)_Y
- SET J=J+$LENGTH(Y)
- +4 WRITE !!
- +5 FOR I=1:1
- IF '$DATA(A(I))
- QUIT
- WRITE !,"Line ",I,": ",A(I)
- +6 SET L=I-1
- E2 ;
- +1 WRITE !!,"Edit Line #: "
- +2 DO READ^ACHSFU
- +3 IF $GET(ACHSQUIT)
- GOTO END
- +4 IF Y?1"?".E
- WRITE !," Enter The Number Of The Line You Wish To Edit",!," Select 1 to ",L
- GOTO E2
- +5 IF Y=""
- GOTO E9
- +6 IF +Y'=Y!(Y<1)!(Y>L)
- WRITE *7," ??"
- GOTO E2
- +7 SET X=A(Y)
- SET N=Y
- E3 ;
- +1 WRITE !,X,!," Replace: "
- +2 DO READ^ACHSFU
- +3 IF $DATA(DUOUT)
- GOTO E1
- IF $GET(ACHSQUIT)
- GOTO END
- IF Y?1"?".E
- GOTO Q2
- +4 IF Y="END"
- SET P=$CHAR(1)
- GOTO E6
- +5 IF Y=""
- GOTO E7
- +6 DO SB1
- +7 IF P=""
- WRITE *7," ??"
- GOTO E3
- E6 ;
- +1 IF $X>60
- WRITE !
- +2 WRITE " With: "
- +3 DO READ^ACHSFU
- +4 IF $DATA(DUOUT)
- GOTO E1
- IF $GET(ACHSQUIT)
- GOTO END
- +5 IF Y?1"?".E
- WRITE !," Enter The New Characters or 'RETURN' If None"
- GOTO E6
- +6 SET X=$PIECE(X,P)_Y_$PIECE(X,P,2,999)
- +7 IF X]""
- GOTO E3
- GOTO E7
- E7 ;
- +1 SET ACHSBLT=""
- SET L=0
- SET A(N)=X
- +2 FOR I=1:1
- IF '$DATA(A(I))
- QUIT
- IF A(I)]""
- SET L=L+$LENGTH(A(I))
- IF L>150
- GOTO E8
- IF ACHSBLT]""
- SET ACHSBLT=ACHSBLT_" "
- SET ACHSBLT=ACHSBLT_A(I)
- +3 GOTO E1
- +4 ;
- E8 ;
- +1 SET ACHSBLT=ACHSBLT_$SELECT(ACHSBLT="":"",1:" ")_$EXTRACT(A(I),1,150-$LENGTH(ACHSBLT))
- +2 WRITE *7,!," Too Long... (150 Character Max.)"
- +3 GOTO E1
- +4 ;
- E9 ;
- +1 IF ACHSBLT=""
- KILL ACHSBLT
- END ;
- +1 KILL A,B,C,E,F,I,J,L,N,P,R,S,W,X
- +2 QUIT
- +3 ;
- SB1 ;
- +1 SET F=$LENGTH(Y,"...")
- SET (P,S)=""
- +2 IF F>2
- QUIT
- +3 SET R=$PIECE(Y,"...")
- SET E=$FIND(X,R)
- +4 IF 'E
- QUIT
- +5 SET E=E-1
- +6 SET B=E-$LENGTH(R)+1
- +7 IF F>1
- SET Y=$PIECE(Y,"...",2)
- IF Y=""
- SET E=999
- IF Y]""
- SET W=$FIND(X,Y,E+1)
- IF 'W
- QUIT
- SET E=W-1
- +8 SET P=$EXTRACT(X,B,E)
- +9 QUIT
- +10 ;
- Q1 ;
- +1 WRITE !!," Enter A Description For This Document.",!," It Will Be Printed In Place Of The",!," Patient Identification Data On The Form."
- +2 WRITE !!," The Maximun Length Allowed Is 150 Characters.",!," Type The Description In Single Stream Of Characters",!," (ie. Don't Press The Return Key Until The End)."
- +3 GOTO A1
- +4 ;
- Q2 ;
- +1 WRITE !!," Enter The Characters You Wish To Delete.",!," Then You Will Be Asked To Enter The Characters To",!," Replace The Just Deleted Characters, If any.",!
- +2 GOTO E3
- +3 ;
