Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPOLM

RMPOLM.m

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