- 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 Feb 18, 2025@23:46: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