IBCSCP ;ALB/MRL - BILLING SCREEN PROCESSOR ;01 JUN 88 12:00
;;2.0;INTEGRATED BILLING;**52,51,161,266,432,447,547**;21-MAR-94;Build 119
;;Per VA Directive 6402, 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 !
S IBPOPOUT=0
S (ICDVDT,ICPTVDT)=$$BDATE^IBACSV(IBIFN) ;ICD/CPT version date
; IB*2.0*447 BI Start
;W "<RET> to ",$S(+IBSR<10:"CONTINUE",1:"QUIT") W:$S(+IBSR=9&(IBV1'["0"):0,1:'IBV) ", ",IBCSCPP," to EDIT," W " '^N' for screen N, or '^' to QUIT: " R IBSCNN:DTIME S IBCITOUT='$T G Q:'$T I IBSCNN="" S X1=2 G NOMO
W "<RET> to ",$S(+IBSR<11:"CONTINUE",1:"QUIT") W:$S(+IBSR=11&(IBV1'["0"):0,1:'IBV) ", ",IBCSCPP," to EDIT," W " '^N' for screen N, or '^' to QUIT: " R IBSCNN:DTIME S IBCITOUT='$T G Q:'$T I IBSCNN="" S X1=2 G NOMO
; IB*2.0*447 BI End
G AN:IBSCNN?1"^"1N.N
I IBSCNN?1"^".E S IBPOPOUT=1 G Q
I IBSCNN'?1N.E D ^IBCSCH S X=IBSR,X1=2 G NOMO2
;
; WCJ;IB*2*547;allow more than 9 sections on a screen
;I IBSCNN?1N1"-"1N S IBDR20=IBSCNN,IBSCNN="" F I=+IBDR20:1:$P(IBDR20,"-",2) S IBSCNN=IBSCNN_I_","
I IBSCNN?1N1"-"1.2N,$P(IBSCNN,"-",2)'>$L(IBV1) S IBDR20=IBSCNN,IBSCNN="" F I=+IBDR20:1:$P(IBDR20,"-",2) S IBSCNN=IBSCNN_I_","
;
; IB*2.0*447 BI Start
S IBDR20="" F J=1:1 S I=$P(IBSCNN,",",J) Q:I=""!($L(I)>3) I I<11 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>11 Q
; IB*2.0*447 BI End
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,ICDVDT,ICPTVDT
;
; If Ingenix ClaimsManager found some errors and the user is trying
; to exit from these screens, then capture the user's comments.
; Exit by time-out or by "^" pop out.
; Here, it's important to preserve the value of $T since it is
; being looked at by IBCB.
;
S IBCIT("SAVE THE VALUE OF $T")=$T ; save $T
I $$CM^IBCIUT1(IBIFN),$P($G(^IBA(351.9,IBIFN,0)),U,2)=4,($G(IBPOPOUT)!$G(IBCITOUT)) D COMMENT^IBCIUT7(IBIFN,1)
I IBCIT("SAVE THE VALUE OF $T") ; restore $T
;
Q1 K %DT,C,DGA,DGA1,DGA2,DGAD,DGCC,IBSCNN,IBCSCPP,IBDR20,DGDR1,DGST,DGAAC,DGRCD,IBCPTX,IBCITOUT,IBCIT
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,IBUCH
K DIC,DIWF,DIWL,I,I1,I2,I3,J,X,X1,X2,X3,Y,Z,Z1,Z2
Q
; IB*2.0*447 BI Start
NOMO S I=IBSR,J=1 I +IBSR=11 S X=IBSR G NOMO2
NOMO1 S I=I+1,J=+$E(IBVV,I),X=I S:J&(+X=11) IBSR=X G NOMO2:+X=11 I J G NOMO1
NOMO2 I +IBSR=11&(IBSCNN="") S X1=3,IBSR1=""
S:(+IBSR=10)&(IBSCNN="") IBSR1="" S X=$P($T(@(IBSR1_X)),";;",X1) G @X
Q
; IB*2.0*447 BI End
;
AN S X=+$E(IBSCNN,2,99),X1=$P($T(@X),";;",2) I X1]"",'$E(IBVV,X) S IBSR1="",X1=2 G NOMO2
; IB*2.0*447 BI Start
S Z="INVALID SCREEN NUMBER...VALID SCREENS ARE " F I=1:1:11 I '$E(IBVV,I) S Z=Z_I_$S(I<11:",",1:".")
; IB*2.0*447 BI End
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;;^IBCSC9
9 ;;^IBCSC9;;^IBCSC10
; IB*2.0*447 BI Start
10 ;;^IBCSC10;;^IBCSC11
210 ;;^IBCSC102;;^IBCSC11
H10 ;;^IBCSC10H;;^IBCSC11
11 ;;^IBCSC11;;Q^IBCSCP
; IB*2.0*447 BI End
PAR ;;^IBCPAR;;^IBCPAR
;IBCSCP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSCP 3554 printed Apr 09, 2024@21:30:56 Page 2
IBCSCP ;ALB/MRL - BILLING SCREEN PROCESSOR ;01 JUN 88 12:00
+1 ;;2.0;INTEGRATED BILLING;**52,51,161,266,432,447,547**;21-MAR-94;Build 119
+2 ;;Per VA Directive 6402, 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 SET IBPOPOUT=0
+10 ;ICD/CPT version date
SET (ICDVDT,ICPTVDT)=$$BDATE^IBACSV(IBIFN)
+11 ; IB*2.0*447 BI Start
+12 ;W "<RET> to ",$S(+IBSR<10:"CONTINUE",1:"QUIT") W:$S(+IBSR=9&(IBV1'["0"):0,1:'IBV) ", ",IBCSCPP," to EDIT," W " '^N' for screen N, or '^' to QUIT: " R IBSCNN:DTIME S IBCITOUT='$T G Q:'$T I IBSCNN="" S X1=2 G NOMO
+13 WRITE "<RET> to ",$SELECT(+IBSR<11:"CONTINUE",1:"QUIT")
if $SELECT(+IBSR=11&(IBV1'["0")
WRITE ", ",IBCSCPP," to EDIT,"
WRITE " '^N' for screen N, or '^' to QUIT: "
READ IBSCNN:DTIME
SET IBCITOUT='$TEST
if '$TEST
GOTO Q
IF IBSCNN=""
SET X1=2
GOTO NOMO
+14 ; IB*2.0*447 BI End
+15 if IBSCNN?1"^"1N.N
GOTO AN
+16 IF IBSCNN?1"^".E
SET IBPOPOUT=1
GOTO Q
+17 IF IBSCNN'?1N.E
DO ^IBCSCH
SET X=IBSR
SET X1=2
GOTO NOMO2
+18 ;
+19 ; WCJ;IB*2*547;allow more than 9 sections on a screen
+20 ;I IBSCNN?1N1"-"1N S IBDR20=IBSCNN,IBSCNN="" F I=+IBDR20:1:$P(IBDR20,"-",2) S IBSCNN=IBSCNN_I_","
+21 IF IBSCNN?1N1"-"1.2N
IF $PIECE(IBSCNN,"-",2)'>$LENGTH(IBV1)
SET IBDR20=IBSCNN
SET IBSCNN=""
FOR I=+IBDR20:1:$PIECE(IBDR20,"-",2)
SET IBSCNN=IBSCNN_I_","
+22 ;
+23 ; IB*2.0*447 BI Start
+24 SET IBDR20=""
FOR J=1:1
SET I=$PIECE(IBSCNN,",",J)
if I=""!($LENGTH(I)>3)
QUIT
IF I<11
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>11
QUIT
+25 ; IB*2.0*447 BI End
+26 SET DGDR1=""
FOR J=1:1
SET I=$PIECE(IBDR20,",",J)
if I=""
QUIT
IF '$EXTRACT(IBV1,I)
SET DGDR1=DGDR1_(I+(IBSR*10))_","
+27 IF DGDR1']""
DO ^IBCSCH
SET X=IBSR
SET X1=2
GOTO NOMO2
+28 SET IBDR20=DGDR1
DO ^IBCSCE
SET X=IBSR
SET X1=2
GOTO NOMO2
Q KILL IBSR,IBVV,VADM,IBVI,IBVO,ICDVDT,ICPTVDT
+1 ;
+2 ; If Ingenix ClaimsManager found some errors and the user is trying
+3 ; to exit from these screens, then capture the user's comments.
+4 ; Exit by time-out or by "^" pop out.
+5 ; Here, it's important to preserve the value of $T since it is
+6 ; being looked at by IBCB.
+7 ;
+8 ; save $T
SET IBCIT("SAVE THE VALUE OF $T")=$TEST
+9 IF $$CM^IBCIUT1(IBIFN)
IF $PIECE($GET(^IBA(351.9,IBIFN,0)),U,2)=4
IF ($GET(IBPOPOUT)!$GET(IBCITOUT))
DO COMMENT^IBCIUT7(IBIFN,1)
+10 ; restore $T
IF IBCIT("SAVE THE VALUE OF $T")
+11 ;
Q1 KILL %DT,C,DGA,DGA1,DGA2,DGAD,DGCC,IBSCNN,IBCSCPP,IBDR20,DGDR1,DGST,DGAAC,DGRCD,IBCPTX,IBCITOUT,IBCIT
+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,IBUCH
+2 KILL DIC,DIWF,DIWL,I,I1,I2,I3,J,X,X1,X2,X3,Y,Z,Z1,Z2
+3 QUIT
+4 ; IB*2.0*447 BI Start
NOMO SET I=IBSR
SET J=1
IF +IBSR=11
SET X=IBSR
GOTO NOMO2
NOMO1 SET I=I+1
SET J=+$EXTRACT(IBVV,I)
SET X=I
if J&(+X=11)
SET IBSR=X
if +X=11
GOTO NOMO2
IF J
GOTO NOMO1
NOMO2 IF +IBSR=11&(IBSCNN="")
SET X1=3
SET IBSR1=""
+1 if (+IBSR=10)&(IBSCNN="")
SET IBSR1=""
SET X=$PIECE($TEXT(@(IBSR1_X)),";;",X1)
GOTO @X
+2 QUIT
+3 ; IB*2.0*447 BI End
+4 ;
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 ; IB*2.0*447 BI Start
+2 SET Z="INVALID SCREEN NUMBER...VALID SCREENS ARE "
FOR I=1:1:11
IF '$EXTRACT(IBVV,I)
SET Z=Z_I_$SELECT(I<11:",",1:".")
+3 ; IB*2.0*447 BI End
+4 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;;^IBCSC9
9 ;;^IBCSC9;;^IBCSC10
+1 ; IB*2.0*447 BI Start
10 ;;^IBCSC10;;^IBCSC11
210 ;;^IBCSC102;;^IBCSC11
H10 ;;^IBCSC10H;;^IBCSC11
11 ;;^IBCSC11;;Q^IBCSCP
+1 ; IB*2.0*447 BI End
PAR ;;^IBCPAR;;^IBCPAR
+1 ;IBCSCP
