source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOLM.m@ 1397

RMPOLM ;EDS/MDB-HINES CIOFO/HNC,RVD - HOME OXYGEN LISTMAN CODE ;7/24/98
 ;;3.0;PROSTHETICS;**29,46,49,50**;Feb 09, 1996
 ;ODJ - Fix FCP problem - patch 49
 ;      (all PSAS FCPs should go into '910' col. else 'Other' col.)
 ;      also fix problem where you can get null FCP
 ;ODJ - Fix looping problem in INIT - patch 50
 ;
 Q
EN ; -- main entry point for RMPO BILLING TRANSACTION
 D EN^VALM("RMPO BILLING TRANSACTION")
 Q
 ;
HDR ; -- header code
 S VALMHDR(1)="Billing Transactions for "_$P(^PRC(440,RMPOVDR,0),U)
 S Y=RMPODATE X ^DD("DD")
 S VALMHDR(2)="for "_Y
 Q
 ;
INIT ; -- init variables and list array
 ;
 S DFLAG=$G(DFLAG,"B")  ; DISPLAY FLAG A=ACCEPTED, U=UNACCEPTED, B=BOTH
 S LINE=0,DFN=0,VDR=RMPOVDR,SITE=RMPOXITE,RVDT=RMPORVDT,FN=665.72
 S RMPRPT=0
 F  S RMPRPT=$O(^RMPO(FN,"AB",RMPRPT)) Q:RMPRPT=""  D
 . S DFN=""
 . F  S DFN=$O(^RMPO(FN,"AB",RMPRPT,SITE,RVDT,VDR,DFN)) Q:DFN=""  D
 .. I '$D(^RMPO(FN,SITE,1,RVDT,1,VDR,"V",DFN,0)) K ^RMPO(FN,"AB",RMPRPT,SITE,RVDT,VDR,DFN) Q
 .. ; Quit if Posted
 .. S PSTFLG=$P(^RMPO(FN,SITE,1,RVDT,1,VDR,"V",DFN,0),U,3)
 .. Q:PSTFLG="Y"
 .. S PITM=$P($$PIEN^RMPOPED(DFN),U,2)
 .. 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
 .. Q:'$G(PITM)
 .. S PSTFLG=$S(PSTFLG="P":"p",1:"")
 .. D DEM^VADPT S NAME=$E(VADM(1),0,11),SSN=VA("BID")
 .. S ELIG=$P(^RMPR(665,DFN,"RMPOA"),U)
 .. S ACCFLG=$P(^RMPO(FN,SITE,1,RVDT,1,VDR,"V",DFN,0),U,2)
 .. S ACCFLG=$S(ACCFLG="Y":"a",1:"")
 .. I DFLAG="U" Q:ACCFLG]""
 .. I DFLAG="A" Q:ACCFLG=""
 .. S ITM=0,T910=0,OTH=0,TOTAL=0,SUSP=0,PST910=" ",PSTOTH=" "
 .. F  S ITM=$O(^RMPO(FN,SITE,1,RVDT,1,VDR,"V",DFN,1,ITM)) Q:ITM'>0  D
 ... S NODE=^RMPO(FN,SITE,1,RVDT,1,VDR,"V",DFN,1,ITM,0)
 ... S AMT=$P(NODE,U,6),SUSPI=$P(NODE,U,11)
 ... S SUSP=SUSP+SUSPI
 ... I $$PSASFCP(SITE,$P(NODE,U,3)) D
 .... S T910=T910+AMT+SUSPI
 .... I $P(NODE,U,10)="Y" S PST910="*"
 .... Q
 ... E  D
 .... S OTH=OTH+AMT+SUSPI
 .... I $P(NODE,U,10)="Y" S PSTOTH="*"
 .... Q
 ... ; S TOTAL=TOTAL+AMT-SUSPI
 ... S TOTAL=TOTAL+AMT
 ... Q
 .. S ITEMNM=$P($$ITEMNM^RMPOPED(PITM),U)
 .. S LINE=LINE+1
 .. S X=$$SETFLD^VALM1($J(LINE,2)_".","","NUMBER")
 .. S X=$$SETFLD^VALM1(ELIG,X,"ELIG")
 .. S X=$$SETFLD^VALM1(SSN,X,"SSN")
 .. S X=$$SETFLD^VALM1(NAME,X,"NAME")
 .. S X=$$SETFLD^VALM1(ITEMNM,X,"PRIMARY ITEM")
 .. S X=$$SETFLD^VALM1($$RJ(T910,"T910",PST910="*")_PST910,X,"T910")
 .. S X=$$SETFLD^VALM1($$RJ(OTH,"OTHER",PSTOTH="*")_PSTOTH,X,"OTHER")
 .. S X=$$SETFLD^VALM1($$RJ(TOTAL,"TOTAL"),X,"TOTAL")
 .. S X=$$SETFLD^VALM1($$RJ(SUSP,"SUSP"),X,"SUSP")
 .. S X=$$SETFLD^VALM1(ACCFLG,X,"ACCFLG")
 .. S X=$$SETFLD^VALM1(PSTFLG,X,"PSTFLG")
 .. D SET^VALM10(LINE,X,DFN)
 .. Q
 . Q
 S VALMCNT=LINE
 Q
 ;
RJ(FLDVAL,FLDNAM,OFFSET) ; RIGHT-JUSTIFY FIELD
 ;
 Q $J(FLDVAL,$P(VALMDDF(FLDNAM),U,3)-$G(OFFSET),2)
 Q
HELP ; -- help code
 S X="?" D DISP^XQORM1 W !!
 Q
 ;
EXIT ; -- exit code
 K DFLAG,DIC,DIE,DIR,DO,DD,DA,DIROUT,DTOUT,DUOUT,FLDVAL,FLDNAM,OFFSET
 K LINE,DFN,VDR,SITE,RVDT,FN,PSTFLG,PITM,NAME,SSN,ELIG,ACCFLG,ITM,T910
 K OTH,SUSP,PST910,PSTOTH,NODE,AMT,SUSPI,TOTAL,ITEMNM,VALMCNT,VALMHDR,X,Y
 K VALMAR,VALMBCK,VALMBG,VALMLST,VALMDDF,VADM,RMPRPT
 Q
 ;
EXPND ; -- expand code
 Q
 ;
 ; (p49) Function returns 1 if an FCP is a PSAS site, 0 if not.
 ; Anything other than a Y in the field is assumed non PSAS
 ; Inputs are Site (subsc 2 in RMPR(669.9
 ;            FCP (subsc 5 in RMPR(669.9,Site,"RMPOFCP","B"
PSASFCP(RMPOXITE,RFCPI) ;
 N RFCPIEN,REC,RET
 S RET=0
 I RMPOXITE=""!(RFCPI="") G PSASFCPX
 S RFCPIEN=$O(^RMPR(669.9,RMPOXITE,"RMPOFCP","B",RFCPI,0))
 I RFCPIEN="" G PSASFCPX
 S REC=$G(^RMPR(669.9,RMPOXITE,"RMPOFCP",RFCPIEN,0))
 I $P(REC,U,2)="Y" S RET=1
PSASFCPX ;
 Q RET