source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOLM.m@ 1005

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1RMPOLM ;EDS/MDB-HINES CIOFO/HNC,RVD - HOME OXYGEN LISTMAN CODE ;7/24/98
2 ;;3.0;PROSTHETICS;**29,46,49,50**;Feb 09, 1996
3 ;ODJ - Fix FCP problem - patch 49
4 ; (all PSAS FCPs should go into '910' col. else 'Other' col.)
5 ; also fix problem where you can get null FCP
6 ;ODJ - Fix looping problem in INIT - patch 50
7 ;
8 Q
9EN ; -- main entry point for RMPO BILLING TRANSACTION
10 D EN^VALM("RMPO BILLING TRANSACTION")
11 Q
12 ;
13HDR ; -- header code
14 S VALMHDR(1)="Billing Transactions for "_$P(^PRC(440,RMPOVDR,0),U)
15 S Y=RMPODATE X ^DD("DD")
16 S VALMHDR(2)="for "_Y
17 Q
18 ;
19INIT ; -- init variables and list array
20 ;
21 S DFLAG=$G(DFLAG,"B") ; DISPLAY FLAG A=ACCEPTED, U=UNACCEPTED, B=BOTH
22 S LINE=0,DFN=0,VDR=RMPOVDR,SITE=RMPOXITE,RVDT=RMPORVDT,FN=665.72
23 S RMPRPT=0
24 F S RMPRPT=$O(^RMPO(FN,"AB",RMPRPT)) Q:RMPRPT="" D
25 . S DFN=""
26 . F S DFN=$O(^RMPO(FN,"AB",RMPRPT,SITE,RVDT,VDR,DFN)) Q:DFN="" D
27 .. I '$D(^RMPO(FN,SITE,1,RVDT,1,VDR,"V",DFN,0)) K ^RMPO(FN,"AB",RMPRPT,SITE,RVDT,VDR,DFN) Q
28 .. ; Quit if Posted
29 .. S PSTFLG=$P(^RMPO(FN,SITE,1,RVDT,1,VDR,"V",DFN,0),U,3)
30 .. Q:PSTFLG="Y"
31 .. S PITM=$P($$PIEN^RMPOPED(DFN),U,2)
32 .. I '$G(PITM) W !!,$C(7),"Patient: ",$P($G(^DPT(DFN,0)),U)," has no primary ITEM, please ENTER a PRIMARY item before posting..." H 3
33 .. Q:'$G(PITM)
34 .. S PSTFLG=$S(PSTFLG="P":"p",1:"")
35 .. D DEM^VADPT S NAME=$E(VADM(1),0,11),SSN=VA("BID")
36 .. S ELIG=$P(^RMPR(665,DFN,"RMPOA"),U)
37 .. S ACCFLG=$P(^RMPO(FN,SITE,1,RVDT,1,VDR,"V",DFN,0),U,2)
38 .. S ACCFLG=$S(ACCFLG="Y":"a",1:"")
39 .. I DFLAG="U" Q:ACCFLG]""
40 .. I DFLAG="A" Q:ACCFLG=""
41 .. S ITM=0,T910=0,OTH=0,TOTAL=0,SUSP=0,PST910=" ",PSTOTH=" "
42 .. F S ITM=$O(^RMPO(FN,SITE,1,RVDT,1,VDR,"V",DFN,1,ITM)) Q:ITM'>0 D
43 ... S NODE=^RMPO(FN,SITE,1,RVDT,1,VDR,"V",DFN,1,ITM,0)
44 ... S AMT=$P(NODE,U,6),SUSPI=$P(NODE,U,11)
45 ... S SUSP=SUSP+SUSPI
46 ... I $$PSASFCP(SITE,$P(NODE,U,3)) D
47 .... S T910=T910+AMT+SUSPI
48 .... I $P(NODE,U,10)="Y" S PST910="*"
49 .... Q
50 ... E D
51 .... S OTH=OTH+AMT+SUSPI
52 .... I $P(NODE,U,10)="Y" S PSTOTH="*"
53 .... Q
54 ... ; S TOTAL=TOTAL+AMT-SUSPI
55 ... S TOTAL=TOTAL+AMT
56 ... Q
57 .. S ITEMNM=$P($$ITEMNM^RMPOPED(PITM),U)
58 .. S LINE=LINE+1
59 .. S X=$$SETFLD^VALM1($J(LINE,2)_".","","NUMBER")
60 .. S X=$$SETFLD^VALM1(ELIG,X,"ELIG")
61 .. S X=$$SETFLD^VALM1(SSN,X,"SSN")
62 .. S X=$$SETFLD^VALM1(NAME,X,"NAME")
63 .. S X=$$SETFLD^VALM1(ITEMNM,X,"PRIMARY ITEM")
64 .. S X=$$SETFLD^VALM1($$RJ(T910,"T910",PST910="*")_PST910,X,"T910")
65 .. S X=$$SETFLD^VALM1($$RJ(OTH,"OTHER",PSTOTH="*")_PSTOTH,X,"OTHER")
66 .. S X=$$SETFLD^VALM1($$RJ(TOTAL,"TOTAL"),X,"TOTAL")
67 .. S X=$$SETFLD^VALM1($$RJ(SUSP,"SUSP"),X,"SUSP")
68 .. S X=$$SETFLD^VALM1(ACCFLG,X,"ACCFLG")
69 .. S X=$$SETFLD^VALM1(PSTFLG,X,"PSTFLG")
70 .. D SET^VALM10(LINE,X,DFN)
71 .. Q
72 . Q
73 S VALMCNT=LINE
74 Q
75 ;
76RJ(FLDVAL,FLDNAM,OFFSET) ; RIGHT-JUSTIFY FIELD
77 ;
78 Q $J(FLDVAL,$P(VALMDDF(FLDNAM),U,3)-$G(OFFSET),2)
79 Q
80HELP ; -- help code
81 S X="?" D DISP^XQORM1 W !!
82 Q
83 ;
84EXIT ; -- exit code
85 K DFLAG,DIC,DIE,DIR,DO,DD,DA,DIROUT,DTOUT,DUOUT,FLDVAL,FLDNAM,OFFSET
86 K LINE,DFN,VDR,SITE,RVDT,FN,PSTFLG,PITM,NAME,SSN,ELIG,ACCFLG,ITM,T910
87 K OTH,SUSP,PST910,PSTOTH,NODE,AMT,SUSPI,TOTAL,ITEMNM,VALMCNT,VALMHDR,X,Y
88 K VALMAR,VALMBCK,VALMBG,VALMLST,VALMDDF,VADM,RMPRPT
89 Q
90 ;
91EXPND ; -- expand code
92 Q
93 ;
94 ; (p49) Function returns 1 if an FCP is a PSAS site, 0 if not.
95 ; Anything other than a Y in the field is assumed non PSAS
96 ; Inputs are Site (subsc 2 in RMPR(669.9
97 ; FCP (subsc 5 in RMPR(669.9,Site,"RMPOFCP","B"
98PSASFCP(RMPOXITE,RFCPI) ;
99 N RFCPIEN,REC,RET
100 S RET=0
101 I RMPOXITE=""!(RFCPI="") G PSASFCPX
102 S RFCPIEN=$O(^RMPR(669.9,RMPOXITE,"RMPOFCP","B",RFCPI,0))
103 I RFCPIEN="" G PSASFCPX
104 S REC=$G(^RMPR(669.9,RMPOXITE,"RMPOFCP",RFCPIEN,0))
105 I $P(REC,U,2)="Y" S RET=1
106PSASFCPX ;
107 Q RET
Note: See TracBrowser for help on using the repository browser.