- 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
