- 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 Feb 18, 2025@23:57:33 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