source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCP.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.7 KB
Line 
1IBCSCP ;ALB/MRL - BILLING SCREEN PROCESSOR ;01 JUN 88 12:00
2 ;;2.0;INTEGRATED BILLING;**52,51,161,266**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;MAP TO DGCRSCP
6 ;
7 D Q1 W !
8 S IBCSCPP=$S($L(IBV1)>1:"1-"_$L(IBV1),1:1)
9 F I=$Y:1:20 W !
10 S IBPOPOUT=0
11 S (ICDVDT,ICPTVDT)=$$BDATE^IBACSV(IBIFN) ;ICD/CPT version date
12 W "<RET> to ",$S(+IBSR<9:"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 G AN:IBSCNN?1"^"1N.N
14 I IBSCNN?1"^".E S IBPOPOUT=1 G Q
15 I IBSCNN'?1N.E D ^IBCSCH S X=IBSR,X1=2 G NOMO2
16 I IBSCNN?1N1"-"1N S IBDR20=IBSCNN,IBSCNN="" F I=+IBDR20:1:$P(IBDR20,"-",2) S IBSCNN=IBSCNN_I_","
17 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
18 S DGDR1="" F J=1:1 S I=$P(IBDR20,",",J) Q:I="" I '$E(IBV1,I) S DGDR1=DGDR1_(I+(IBSR*10))_","
19 I DGDR1']"" D ^IBCSCH S X=IBSR,X1=2 G NOMO2
20 S IBDR20=DGDR1 D ^IBCSCE S X=IBSR,X1=2 G NOMO2
21Q K IBSR,IBVV,VADM,IBVI,IBVO,ICDVDT,ICPTVDT
22 ;
23 ; If Ingenix ClaimsManager found some errors and the user is trying
24 ; to exit from these screens, then capture the user's comments.
25 ; Exit by time-out or by "^" pop out.
26 ; Here, it's important to preserve the value of $T since it is
27 ; being looked at by IBCB.
28 ;
29 S IBCIT("SAVE THE VALUE OF $T")=$T ; save $T
30 I $$CM^IBCIUT1(IBIFN),$P($G(^IBA(351.9,IBIFN,0)),U,2)=4,($G(IBPOPOUT)!$G(IBCITOUT)) D COMMENT^IBCIUT7(IBIFN,1)
31 I IBCIT("SAVE THE VALUE OF $T") ; restore $T
32 ;
33Q1 K %DT,C,DGA,DGA1,DGA2,DGAD,DGCC,IBSCNN,IBCSCPP,IBDR20,DGDR1,DGST,DGAAC,DGRCD,IBCPTX,IBCITOUT,IBCIT
34 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
35 K DIC,DIWF,DIWL,I,I1,I2,I3,J,X,X1,X2,X3,Y,Z,Z1,Z2
36 Q
37NOMO S I=IBSR,J=1 I +IBSR=9 S X=IBSR G NOMO2
38NOMO1 S I=I+1,J=+$E(IBVV,I),X=I S:J&(+X=9) IBSR=X G NOMO2:+X=9 I J G NOMO1
39NOMO2 I +IBSR=9&(IBSCNN="") S X1=3,IBSR1=""
40 S:+IBSR=8&(IBSCNN="") IBSR1="" S X=$P($T(@(IBSR1_X)),";;",X1) G @X
41 Q
42 ;
43AN S X=+$E(IBSCNN,2,99),X1=$P($T(@X),";;",2) I X1]"",'$E(IBVV,X) S IBSR1="",X1=2 G NOMO2
44 S Z="INVALID SCREEN NUMBER...VALID SCREENS ARE " F I=1:1:9 I '$E(IBVV,I) S Z=Z_I_$S(I<9:",",1:".")
45 W !,*7 D W H 1 S X=IBSR,X1=2 G NOMO2
46W ;I IOST="C-QUME",$L(IBVI)'=2 W Z
47 W IBVI,Z,IBVO
48 Q
491 ;;^IBCSC1;;^IBCSC2
502 ;;^IBCSC2;;^IBCSC3
513 ;;^IBCSC3;;^IBCSC4
524 ;;^IBCSC4;;^IBCSC5
535 ;;^IBCSC5;;^IBCSC6
546 ;;^IBCSC6;;^IBCSC7
557 ;;^IBCSC7;;^IBCSC8
568 ;;^IBCSC8;;^IBCSC9
579 ;;^IBCSC9;;Q^IBCSCP
5828 ;;^IBCSC82;;^IBCSC9
59H8 ;;^IBCSC8H;;^IBCSC9
60PAR ;;^IBCPAR;;^IBCPAR
61 ;IBCSCP
Note: See TracBrowser for help on using the repository browser.