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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOLM 3822 printed Oct 16, 2024@18:31:44 Page 2
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
+2 ;ODJ - Fix FCP problem - patch 49
+3 ; (all PSAS FCPs should go into '910' col. else 'Other' col.)
+4 ; also fix problem where you can get null FCP
+5 ;ODJ - Fix looping problem in INIT - patch 50
+6 ;
+7 QUIT
EN ; -- main entry point for RMPO BILLING TRANSACTION
+1 DO EN^VALM("RMPO BILLING TRANSACTION")
+2 QUIT
+3 ;
HDR ; -- header code
+1 SET VALMHDR(1)="Billing Transactions for "_$PIECE(^PRC(440,RMPOVDR,0),U)
+2 SET Y=RMPODATE
XECUTE ^DD("DD")
+3 SET VALMHDR(2)="for "_Y
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 ;
+2 ; DISPLAY FLAG A=ACCEPTED, U=UNACCEPTED, B=BOTH
SET DFLAG=$GET(DFLAG,"B")
+3 SET LINE=0
SET DFN=0
SET VDR=RMPOVDR
SET SITE=RMPOXITE
SET RVDT=RMPORVDT
SET FN=665.72
+4 SET RMPRPT=0
+5 FOR
SET RMPRPT=$ORDER(^RMPO(FN,"AB",RMPRPT))
if RMPRPT=""
QUIT
Begin DoDot:1
+6 SET DFN=""
+7 FOR
SET DFN=$ORDER(^RMPO(FN,"AB",RMPRPT,SITE,RVDT,VDR,DFN))
if DFN=""
QUIT
Begin DoDot:2
+8 IF '$DATA(^RMPO(FN,SITE,1,RVDT,1,VDR,"V",DFN,0))
KILL ^RMPO(FN,"AB",RMPRPT,SITE,RVDT,VDR,DFN)
QUIT
+9 ; Quit if Posted
+10 SET PSTFLG=$PIECE(^RMPO(FN,SITE,1,RVDT,1,VDR,"V",DFN,0),U,3)
+11 if PSTFLG="Y"
QUIT
+12 SET PITM=$PIECE($$PIEN^RMPOPED(DFN),U,2)
+13 IF '$GET(PITM)
WRITE !!,$CHAR(7),"Patient: ",$PIECE($GET(^DPT(DFN,0)),U)," has no primary ITEM, please ENTER a PRIMARY item before posting..."
HANG 3
+14 if '$GET(PITM)
QUIT
+15 SET PSTFLG=$SELECT(PSTFLG="P":"p",1:"")
+16 DO DEM^VADPT
SET NAME=$EXTRACT(VADM(1),0,11)
SET SSN=VA("BID")
+17 SET ELIG=$PIECE(^RMPR(665,DFN,"RMPOA"),U)
+18 SET ACCFLG=$PIECE(^RMPO(FN,SITE,1,RVDT,1,VDR,"V",DFN,0),U,2)
+19 SET ACCFLG=$SELECT(ACCFLG="Y":"a",1:"")
+20 IF DFLAG="U"
if ACCFLG]""
QUIT
+21 IF DFLAG="A"
if ACCFLG=""
QUIT
+22 SET ITM=0
SET T910=0
SET OTH=0
SET TOTAL=0
SET SUSP=0
SET PST910=" "
SET PSTOTH=" "
+23 FOR
SET ITM=$ORDER(^RMPO(FN,SITE,1,RVDT,1,VDR,"V",DFN,1,ITM))
if ITM'>0
QUIT
Begin DoDot:3
+24 SET NODE=^RMPO(FN,SITE,1,RVDT,1,VDR,"V",DFN,1,ITM,0)
+25 SET AMT=$PIECE(NODE,U,6)
SET SUSPI=$PIECE(NODE,U,11)
+26 SET SUSP=SUSP+SUSPI
+27 IF $$PSASFCP(SITE,$PIECE(NODE,U,3))
Begin DoDot:4
+28 SET T910=T910+AMT+SUSPI
+29 IF $PIECE(NODE,U,10)="Y"
SET PST910="*"
+30 QUIT
End DoDot:4
+31 IF '$TEST
Begin DoDot:4
+32 SET OTH=OTH+AMT+SUSPI
+33 IF $PIECE(NODE,U,10)="Y"
SET PSTOTH="*"
+34 QUIT
End DoDot:4
+35 ; S TOTAL=TOTAL+AMT-SUSPI
+36 SET TOTAL=TOTAL+AMT
+37 QUIT
End DoDot:3
+38 SET ITEMNM=$PIECE($$ITEMNM^RMPOPED(PITM),U)
+39 SET LINE=LINE+1
+40 SET X=$$SETFLD^VALM1($JUSTIFY(LINE,2)_".","","NUMBER")
+41 SET X=$$SETFLD^VALM1(ELIG,X,"ELIG")
+42 SET X=$$SETFLD^VALM1(SSN,X,"SSN")
+43 SET X=$$SETFLD^VALM1(NAME,X,"NAME")
+44 SET X=$$SETFLD^VALM1(ITEMNM,X,"PRIMARY ITEM")
+45 SET X=$$SETFLD^VALM1($$RJ(T910,"T910",PST910="*")_PST910,X,"T910")
+46 SET X=$$SETFLD^VALM1($$RJ(OTH,"OTHER",PSTOTH="*")_PSTOTH,X,"OTHER")
+47 SET X=$$SETFLD^VALM1($$RJ(TOTAL,"TOTAL"),X,"TOTAL")
+48 SET X=$$SETFLD^VALM1($$RJ(SUSP,"SUSP"),X,"SUSP")
+49 SET X=$$SETFLD^VALM1(ACCFLG,X,"ACCFLG")
+50 SET X=$$SETFLD^VALM1(PSTFLG,X,"PSTFLG")
+51 DO SET^VALM10(LINE,X,DFN)
+52 QUIT
End DoDot:2
+53 QUIT
End DoDot:1
+54 SET VALMCNT=LINE
+55 QUIT
+56 ;
RJ(FLDVAL,FLDNAM,OFFSET) ; RIGHT-JUSTIFY FIELD
+1 ;
+2 QUIT $JUSTIFY(FLDVAL,$PIECE(VALMDDF(FLDNAM),U,3)-$GET(OFFSET),2)
+3 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL DFLAG,DIC,DIE,DIR,DO,DD,DA,DIROUT,DTOUT,DUOUT,FLDVAL,FLDNAM,OFFSET
+2 KILL LINE,DFN,VDR,SITE,RVDT,FN,PSTFLG,PITM,NAME,SSN,ELIG,ACCFLG,ITM,T910
+3 KILL OTH,SUSP,PST910,PSTOTH,NODE,AMT,SUSPI,TOTAL,ITEMNM,VALMCNT,VALMHDR,X,Y
+4 KILL VALMAR,VALMBCK,VALMBG,VALMLST,VALMDDF,VADM,RMPRPT
+5 QUIT
+6 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
+3 ; (p49) Function returns 1 if an FCP is a PSAS site, 0 if not.
+4 ; Anything other than a Y in the field is assumed non PSAS
+5 ; Inputs are Site (subsc 2 in RMPR(669.9
+6 ; FCP (subsc 5 in RMPR(669.9,Site,"RMPOFCP","B"
PSASFCP(RMPOXITE,RFCPI) ;
+1 NEW RFCPIEN,REC,RET
+2 SET RET=0
+3 IF RMPOXITE=""!(RFCPI="")
GOTO PSASFCPX
+4 SET RFCPIEN=$ORDER(^RMPR(669.9,RMPOXITE,"RMPOFCP","B",RFCPI,0))
+5 IF RFCPIEN=""
GOTO PSASFCPX
+6 SET REC=$GET(^RMPR(669.9,RMPOXITE,"RMPOFCP",RFCPIEN,0))
+7 IF $PIECE(REC,U,2)="Y"
SET RET=1
PSASFCPX ;
+1 QUIT RET
