IBCSCP ;ALB/MRL - BILLING SCREEN PROCESSOR ;01 JUN 88 12:00
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;MAP TO DGCRSCP
;
D Q1 W !
S IBCSCPP=$S($L(IBV1)>1:"1-"_$L(IBV1),1:1)
F I=$Y:1:20 W !
W "<RET> to ",$S(+IBSR<8:"CONTINUE",1:"QUIT") W:'IBV ", ",IBCSCPP," to EDIT," W " '^N' for screen N, or '^' to QUIT: " R IBSCNN:DTIME G Q:'$T I IBSCNN="" S X1=2 G NOMO
G AN:IBSCNN?1"^"1N.N,Q:IBSCNN?1"^".E I IBSCNN'?1N.E D ^IBCSCH S X=IBSR,X1=2 G NOMO2
I IBSCNN?1N1"-"1N S IBDR20=IBSCNN,IBSCNN="" F I=+IBDR20:1:$P(IBDR20,"-",2) S IBSCNN=IBSCNN_I_","
S IBDR20="" F J=1:1 S I=$P(IBSCNN,",",J) Q:I=""!($L(I)>3) I I<10 S:I'["-"&(IBDR20'[I_",") IBDR20=IBDR20_I_"," I I["-" S I1=$P(I,"-",1),I2=$P(I,"-",2) F I3=I1:1:I2 S IBDR20=IBDR20_I3_"," I I3>10 Q
S DGDR1="" F J=1:1 S I=$P(IBDR20,",",J) Q:I="" I '$E(IBV1,I) S DGDR1=DGDR1_(I+(IBSR*10))_","
I DGDR1']"" D ^IBCSCH S X=IBSR,X1=2 G NOMO2
S IBDR20=DGDR1 D ^IBCSCE S X=IBSR,X1=2 G NOMO2
Q K IBSR,IBVV,VADM,IBVI,IBVO
Q1 K %DT,C,DGA,DGA1,DGA2,DGAD,DGCC,IBSCNN,IBCSCPP,IBDR20,DGDR1,DGST,DGAAC,DGRCD,IBCPTX
K IBA,IBCPT,IBREVC,IBYN,IBZZ,IBABRT,IB,IBDD,IBIDS,IBIR,IBIRN,IBISEX,IBIUTL,IBU,IBUN,IBW,IBWW,DGPT,IBICD,IBHC,IBCC,IBDI,IBDIN,IBDPT
K DIC,DIWF,DIWL,I,I1,I2,I3,J,X,X1,X2,X3,Y,Z,Z1,Z2 Q
Q
NOMO S I=IBSR,J=1 I +IBSR=8 S X=IBSR G NOMO2
NOMO1 S I=I+1,J=+$E(IBVV,I),X=I G NOMO2:+X=8 I J G NOMO1
NOMO2 S:+IBSR=8&(IBSCNN="") X1=3 S X=$P($T(@(IBSR1_X)),";;",X1) G @X
Q
;
AN S X=+$E(IBSCNN,2,99),X1=$P($T(@X),";;",2) I X1]"",'$E(IBVV,X) S IBSR1="",X1=2 G NOMO2
S Z="INVALID SCREEN NUMBER...VALID SCREENS ARE " F I=1:1:8 I '$E(IBVV,I) S Z=Z_I_$S(I<8:",",1:".")
W !,*7 D W H 1 S X=IBSR,X1=2 G NOMO2
W ;I IOST="C-QUME",$L(IBVI)'=2 W Z
W IBVI,Z,IBVO
Q
1 ;;^IBCSC1;;^IBCSC2
2 ;;^IBCSC2;;^IBCSC3
3 ;;^IBCSC3;;^IBCSC4
4 ;;^IBCSC4;;^IBCSC5
5 ;;^IBCSC5;;^IBCSC6
6 ;;^IBCSC6;;^IBCSC7
7 ;;^IBCSC7;;^IBCSC8
8 ;;^IBCSC8;;Q^IBCSCP
28 ;;^IBCSC82;;Q^IBCSCP
H8 ;;^IBCSC8H;;Q^IBCSCP
PAR ;;^IBCPAR;;^IBCPAR
;IBCSCP
IBCSCP ;ALB/MRL - BILLING SCREEN PROCESSOR ;01 JUN 88 12:00
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRSCP
+5 ;
+6 DO Q1
WRITE !
+7 SET IBCSCPP=$SELECT($LENGTH(IBV1)>1:"1-"_$LENGTH(IBV1),1:1)
+8 FOR I=$Y:1:20
WRITE !
+9 WRITE "<RET> to ",$SELECT(+IBSR<8:"CONTINUE",1:"QUIT")
IF 'IBV
WRITE ", ",IBCSCPP," to EDIT,"
WRITE " '^N' for screen N, or '^' to QUIT: "
READ IBSCNN:DTIME
IF '$TEST
GOTO Q
IF IBSCNN=""
SET X1=2
GOTO NOMO
+10 IF IBSCNN?1"^"1N.N
GOTO AN
IF IBSCNN?1"^".E
GOTO Q
IF IBSCNN'?1N.E
DO ^IBCSCH
SET X=IBSR
SET X1=2
GOTO NOMO2
+11 IF IBSCNN?1N1"-"1N
SET IBDR20=IBSCNN
SET IBSCNN=""
FOR I=+IBDR20:1:$PIECE(IBDR20,"-",2)
SET IBSCNN=IBSCNN_I_","
+12 SET IBDR20=""
FOR J=1:1
SET I=$PIECE(IBSCNN,",",J)
IF I=""!($LENGTH(I)>3)
QUIT
IF I<10
IF I'["-"&(IBDR20'[I_",")
SET IBDR20=IBDR20_I_","
IF I["-"
SET I1=$PIECE(I,"-",1)
SET I2=$PIECE(I,"-",2)
FOR I3=I1:1:I2
SET IBDR20=IBDR20_I3_","
IF I3>10
QUIT
+13 SET DGDR1=""
FOR J=1:1
SET I=$PIECE(IBDR20,",",J)
IF I=""
QUIT
IF '$EXTRACT(IBV1,I)
SET DGDR1=DGDR1_(I+(IBSR*10))_","
+14 IF DGDR1']""
DO ^IBCSCH
SET X=IBSR
SET X1=2
GOTO NOMO2
+15 SET IBDR20=DGDR1
DO ^IBCSCE
SET X=IBSR
SET X1=2
GOTO NOMO2
Q KILL IBSR,IBVV,VADM,IBVI,IBVO
Q1 KILL %DT,C,DGA,DGA1,DGA2,DGAD,DGCC,IBSCNN,IBCSCPP,IBDR20,DGDR1,DGST,DGAAC,DGRCD,IBCPTX
+1 KILL IBA,IBCPT,IBREVC,IBYN,IBZZ,IBABRT,IB,IBDD,IBIDS,IBIR,IBIRN,IBISEX,IBIUTL,IBU,IBUN,IBW,IBWW,DGPT,IBICD,IBHC,IBCC,IBDI,IBDIN,IBDPT
+2 KILL DIC,DIWF,DIWL,I,I1,I2,I3,J,X,X1,X2,X3,Y,Z,Z1,Z2
QUIT
+3 QUIT
NOMO SET I=IBSR
SET J=1
IF +IBSR=8
SET X=IBSR
GOTO NOMO2
NOMO1 SET I=I+1
SET J=+$EXTRACT(IBVV,I)
SET X=I
IF +X=8
GOTO NOMO2
IF J
GOTO NOMO1
NOMO2 IF +IBSR=8&(IBSCNN="")
SET X1=3
SET X=$PIECE($TEXT(@(IBSR1_X)),";;",X1)
GOTO @X
+1 QUIT
+2 ;
AN SET X=+$EXTRACT(IBSCNN,2,99)
SET X1=$PIECE($TEXT(@X),";;",2)
IF X1]""
IF '$EXTRACT(IBVV,X)
SET IBSR1=""
SET X1=2
GOTO NOMO2
+1 SET Z="INVALID SCREEN NUMBER...VALID SCREENS ARE "
FOR I=1:1:8
IF '$EXTRACT(IBVV,I)
SET Z=Z_I_$SELECT(I<8:",",1:".")
+2 WRITE !,*7
DO W
HANG 1
SET X=IBSR
SET X1=2
GOTO NOMO2
W ;I IOST="C-QUME",$L(IBVI)'=2 W Z
+1 WRITE IBVI,Z,IBVO
+2 QUIT
1 ;;^IBCSC1;;^IBCSC2
2 ;;^IBCSC2;;^IBCSC3
3 ;;^IBCSC3;;^IBCSC4
4 ;;^IBCSC4;;^IBCSC5
5 ;;^IBCSC5;;^IBCSC6
6 ;;^IBCSC6;;^IBCSC7
7 ;;^IBCSC7;;^IBCSC8
8 ;;^IBCSC8;;Q^IBCSCP
28 ;;^IBCSC82;;Q^IBCSCP
H8 ;;^IBCSC8H;;Q^IBCSCP
PAR ;;^IBCPAR;;^IBCPAR
+1 ;IBCSCP
