RMPOPST1 ;EDS/JAM,RVD - HOME OXYGEN BILLING TRANSACTIONS/POSTING,Part 2 ;7/24/98
;;3.0;PROSTHETICS;**29,44,55,154,166**;Feb 09, 1996;Build 2
; RVD #55 - corrected the typo (missing '^' on TMP global).
;
;Processing of 1358 and Purchase Cards to IFCAP
Q
IFCAP ;process payment type - Purchase Card or 1358
D @$S($P(PAYINF,U)="P":"PRHCARD",1:"1358")
I $P(^TMP($J,FCP),U,2) D
. W !!,FCP," ...Posted" D FCPUPD ;update global ^RMPO(665.72
K A
Q ;IFCAP
;
PRHCARD ;Processing IFCAP Purchase Card
N DFN,PRCA,PRCB,PRCC,INDVITM,ITMSTR,RMPOA,X,CNT,CURDT,CNTR,TOTD
S PRCA=PCTOT+FCPTOT,PRCB=IEN442,PRCC="RMPOA"
;Store individual patient in array RMPOA for posting
S DFN="",TOTD=0,CNTR=0 F CNT=1:1 S DFN=$O(^TMP($J,FCP,DFN)) Q:DFN="" D
. S ITMSTR=^TMP($J,FCP,DFN),TOTD=TOTD+$P(ITMSTR,U),CNTR=CNTR+1
I CNTR>0 S RMPOA(1)=$J(TOTD,10,2)_" TOTAL PATIENTS= "_CNTR
D EDITIC^PRCH7D(PRCA,PRCB,PRCC)
I X="^" D Q ;PRHCARD
. S $P(^TMP($J,FCP),U,2)=0,$P(^TMP($J,FCP),U,3)="Posting of PC aborted"
. ;W " ",$P(^TMP($J,FCP),U,3)
S $P(^TMP($J,FCP),U,2)=1,$P(^TMP($J,FCP),U,4)=PRCA
D NOW^%DTC S CURDT=%
;Update file 660 and ^RMPO(665.72
S DFN="" F S DFN=$O(^TMP($J,FCP,DFN)) Q:DFN="" D
. S $P(^TMP($J,FCP,DFN),U,3)=1
. D GBLUPD
Q ;PRHCARD
;
1358 ;processing IFCAP 1358
N DFN,IEN424,BAL,CURDT,Y,PATOT,PATINF,PSTFLG,PRCSX,PATINFW
;Check balance on 1358
S BAL=$$BAL(IEN442) I BAL<FCPTOT D Q
. S $P(^TMP($J,FCP),U,2)=0,$P(^TMP($J,FCP),U,3)="Insufficient balance"
. ;W " ",$P(^TMP($J,FCP),U,3)
S PSTFLG=0,DFN=""
F I=1:1 S DFN=$O(^TMP($J,FCP,DFN)) Q:DFN="" D
. ;RMPR166 change identifier from PAT ID to PID to reduce num of chars ticket 786903
. S PATOT=+^TMP($J,FCP,DFN),PATINF="PID "_DFN,PATINFW=$P(^TMP($J,FCP,DFN),U,2)
. ;authorize amount to be posted
. D NOW^%DTC S CURDT=%
. S X=SRVORD_"^"_CURDT_"^"_PATOT_"^^"_PATINF,Y=$$AUTH(X)
. I '+Y D Q
. . S $P(^TMP($J,FCP,DFN),U,3)=0,$P(^TMP($J,FCP,DFN),U,4)=$P(Y,U)_$P(Y,U,2)
. . W !!,"Authorization failed for: ",PATINFW,!
. . W "IFCAP reason: ",$S($P(Y,U,2)'="":$P(Y,U,2),1:$P(Y,U))
. S IEN424=$P(Y,U,2)
. ;post patient total to authorized IEN 424 and closeout posting
. S PRCSX=IEN424_U_CURDT_U_PATOT_U_"HOME OXYGEN COMPLETED"
. S Y=$$COMPST(PRCSX)
. I '+Y D Q
. . S $P(^TMP($J,FCP,DFN),U,3)=0,$P(^TMP($J,FCP,DFN),U,4)=$P(Y,U,2)
. . W !!,"Post Completion failed for: "_PATINFW,!
. . W "IFCAP reason: "_$P(Y,U,2)
. . W "Patient IEN(424): ",IEN424
. S $P(^TMP($J,FCP,DFN),U,3)=1,PSTFLG=1
. ;update file 660 for form 2319 and file ^RMPO(665.72
. D GBLUPD
S $P(^TMP($J,FCP),U,2)=PSTFLG
Q ;1358
;
BAL(A) ;check balance on 1358 Service Order before posting
N TOT442
S TOT442=$$BAL^PRCH58(A)
Q +TOT442-$P(TOT442,U,3) ;BAL
;
AUTH(X) ;create one authorization per patient to be posted
;return IEN of 424 if successful in Y
N PRCS
S PRCS("TYPE")="COUNTER"
D EN2^PRCS58
Q Y ;AUTH
;
COMPST(PRCSX) ;Post patient transactions as complete to IEN of file 424
D ^PRCS58CC
Q Y ;COMPST
;
GBLUPD ;Update file ^RMPO(665.72 and 660
;update file 660 for form 2319
D F660^RMPOPST3
;update ^RMPO(665.72 with post flag
D ITMUPD
Q
;
ITMUPD ;Update global ^RMPO(665.72 with post flag for individual item
N ITM,DASTR
;check if FCP was posted for patient
I '$P(^TMP($J,FCP,DFN),U,3) Q
K DIE,DA,DR
S DA(2)=VDR,DA(3)=RVDT,DA(4)=SITE
S DASTR=DA(4)_",1,"_DA(3)_",1,"_DA(2)_",""V"","
S ITM="" F S ITM=$O(^TMP($J,FCP,DFN,ITM)) Q:ITM="" D
. S DA(1)=DFN,DIE="^RMPO(665.72,"_DASTR_DA(1)_",1,",DR="8///Y",DA=ITM
. D ^DIE
D PATUPD
Q ;ITMUPD
;
PATUPD ;Update global ^RMPO(665.72 with post flag for patient
N FLG,IT,X,PFLG,ISTR,DASTR
K DIE,DA,DR
S DA(1)=DFN,DA(2)=VDR,DA(3)=RVDT,DA(4)=SITE
S IT=0,X=0,FLG="Y"
F S IT=$O(^RMPO(FIL,SITE,1,RVDT,1,VDR,"V",DFN,1,IT)) Q:'IT D I X Q
. S PFLG=$P(^RMPO(FIL,SITE,1,RVDT,1,VDR,"V",DFN,1,IT,0),U,10)
. S RP660=$P(^RMPO(FIL,SITE,1,RVDT,1,VDR,"V",DFN,1,IT,0),U,16)
. I '$G(RP660) S FLG=""
. I PFLG=""!(PFLG="N") D Q
. . I PFLG="" D
. . . S DASTR=DA(4)_",1,"_DA(3)_",1,"_DA(2)_",""V"","_DA(1)_",1,"
. . . S DIE="^RMPO(665.72,"_DASTR,DR="8///N",DA=IT D ^DIE
. . S X=1,FLG="P"
K DIE,DA,DR
S DA(1)=VDR,DA(2)=RVDT,DA(3)=SITE,DA=DFN,DR="3///"_FLG
S DIE="^RMPO(665.72,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",""V"","
D ^DIE
Q ;PATUPD
;
FCPUPD ;Update global ^RMPO(665.72 with totals for Purchase Card
K DIE,DA,DR
S DA=IENFCP,DA(1)=RVDT,DA(2)=SITE
S DIE="^RMPO(665.72,"_DA(2)_",1,"_DA(1)_",2,"
S DR=$S($P(PAYINF,U)="P":"6///"_(FCPTOT+PCTOT)_";",1:"")
S DR=DR_"4////"_DUZ_";"_"5///"_VDR
D ^DIE
Q ;FCPUPD
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOPST1 4678 printed Sep 23, 2025@20:07:33 Page 2
RMPOPST1 ;EDS/JAM,RVD - HOME OXYGEN BILLING TRANSACTIONS/POSTING,Part 2 ;7/24/98
+1 ;;3.0;PROSTHETICS;**29,44,55,154,166**;Feb 09, 1996;Build 2
+2 ; RVD #55 - corrected the typo (missing '^' on TMP global).
+3 ;
+4 ;Processing of 1358 and Purchase Cards to IFCAP
+5 QUIT
IFCAP ;process payment type - Purchase Card or 1358
+1 DO @$SELECT($PIECE(PAYINF,U)="P":"PRHCARD",1:"1358")
+2 IF $PIECE(^TMP($JOB,FCP),U,2)
Begin DoDot:1
+3 ;update global ^RMPO(665.72
WRITE !!,FCP," ...Posted"
DO FCPUPD
End DoDot:1
+4 KILL A
+5 ;IFCAP
QUIT
+6 ;
PRHCARD ;Processing IFCAP Purchase Card
+1 NEW DFN,PRCA,PRCB,PRCC,INDVITM,ITMSTR,RMPOA,X,CNT,CURDT,CNTR,TOTD
+2 SET PRCA=PCTOT+FCPTOT
SET PRCB=IEN442
SET PRCC="RMPOA"
+3 ;Store individual patient in array RMPOA for posting
+4 SET DFN=""
SET TOTD=0
SET CNTR=0
FOR CNT=1:1
SET DFN=$ORDER(^TMP($JOB,FCP,DFN))
if DFN=""
QUIT
Begin DoDot:1
+5 SET ITMSTR=^TMP($JOB,FCP,DFN)
SET TOTD=TOTD+$PIECE(ITMSTR,U)
SET CNTR=CNTR+1
End DoDot:1
+6 IF CNTR>0
SET RMPOA(1)=$JUSTIFY(TOTD,10,2)_" TOTAL PATIENTS= "_CNTR
+7 DO EDITIC^PRCH7D(PRCA,PRCB,PRCC)
+8 ;PRHCARD
IF X="^"
Begin DoDot:1
+9 SET $PIECE(^TMP($JOB,FCP),U,2)=0
SET $PIECE(^TMP($JOB,FCP),U,3)="Posting of PC aborted"
+10 ;W " ",$P(^TMP($J,FCP),U,3)
End DoDot:1
QUIT
+11 SET $PIECE(^TMP($JOB,FCP),U,2)=1
SET $PIECE(^TMP($JOB,FCP),U,4)=PRCA
+12 DO NOW^%DTC
SET CURDT=%
+13 ;Update file 660 and ^RMPO(665.72
+14 SET DFN=""
FOR
SET DFN=$ORDER(^TMP($JOB,FCP,DFN))
if DFN=""
QUIT
Begin DoDot:1
+15 SET $PIECE(^TMP($JOB,FCP,DFN),U,3)=1
+16 DO GBLUPD
End DoDot:1
+17 ;PRHCARD
QUIT
+18 ;
1358 ;processing IFCAP 1358
+1 NEW DFN,IEN424,BAL,CURDT,Y,PATOT,PATINF,PSTFLG,PRCSX,PATINFW
+2 ;Check balance on 1358
+3 SET BAL=$$BAL(IEN442)
IF BAL<FCPTOT
Begin DoDot:1
+4 SET $PIECE(^TMP($JOB,FCP),U,2)=0
SET $PIECE(^TMP($JOB,FCP),U,3)="Insufficient balance"
+5 ;W " ",$P(^TMP($J,FCP),U,3)
End DoDot:1
QUIT
+6 SET PSTFLG=0
SET DFN=""
+7 FOR I=1:1
SET DFN=$ORDER(^TMP($JOB,FCP,DFN))
if DFN=""
QUIT
Begin DoDot:1
+8 ;RMPR166 change identifier from PAT ID to PID to reduce num of chars ticket 786903
+9 SET PATOT=+^TMP($JOB,FCP,DFN)
SET PATINF="PID "_DFN
SET PATINFW=$PIECE(^TMP($JOB,FCP,DFN),U,2)
+10 ;authorize amount to be posted
+11 DO NOW^%DTC
SET CURDT=%
+12 SET X=SRVORD_"^"_CURDT_"^"_PATOT_"^^"_PATINF
SET Y=$$AUTH(X)
+13 IF '+Y
Begin DoDot:2
+14 SET $PIECE(^TMP($JOB,FCP,DFN),U,3)=0
SET $PIECE(^TMP($JOB,FCP,DFN),U,4)=$PIECE(Y,U)_$PIECE(Y,U,2)
+15 WRITE !!,"Authorization failed for: ",PATINFW,!
+16 WRITE "IFCAP reason: ",$SELECT($PIECE(Y,U,2)'="":$PIECE(Y,U,2),1:$PIECE(Y,U))
End DoDot:2
QUIT
+17 SET IEN424=$PIECE(Y,U,2)
+18 ;post patient total to authorized IEN 424 and closeout posting
+19 SET PRCSX=IEN424_U_CURDT_U_PATOT_U_"HOME OXYGEN COMPLETED"
+20 SET Y=$$COMPST(PRCSX)
+21 IF '+Y
Begin DoDot:2
+22 SET $PIECE(^TMP($JOB,FCP,DFN),U,3)=0
SET $PIECE(^TMP($JOB,FCP,DFN),U,4)=$PIECE(Y,U,2)
+23 WRITE !!,"Post Completion failed for: "_PATINFW,!
+24 WRITE "IFCAP reason: "_$PIECE(Y,U,2)
+25 WRITE "Patient IEN(424): ",IEN424
End DoDot:2
QUIT
+26 SET $PIECE(^TMP($JOB,FCP,DFN),U,3)=1
SET PSTFLG=1
+27 ;update file 660 for form 2319 and file ^RMPO(665.72
+28 DO GBLUPD
End DoDot:1
+29 SET $PIECE(^TMP($JOB,FCP),U,2)=PSTFLG
+30 ;1358
QUIT
+31 ;
BAL(A) ;check balance on 1358 Service Order before posting
+1 NEW TOT442
+2 SET TOT442=$$BAL^PRCH58(A)
+3 ;BAL
QUIT +TOT442-$PIECE(TOT442,U,3)
+4 ;
AUTH(X) ;create one authorization per patient to be posted
+1 ;return IEN of 424 if successful in Y
+2 NEW PRCS
+3 SET PRCS("TYPE")="COUNTER"
+4 DO EN2^PRCS58
+5 ;AUTH
QUIT Y
+6 ;
COMPST(PRCSX) ;Post patient transactions as complete to IEN of file 424
+1 DO ^PRCS58CC
+2 ;COMPST
QUIT Y
+3 ;
GBLUPD ;Update file ^RMPO(665.72 and 660
+1 ;update file 660 for form 2319
+2 DO F660^RMPOPST3
+3 ;update ^RMPO(665.72 with post flag
+4 DO ITMUPD
+5 QUIT
+6 ;
ITMUPD ;Update global ^RMPO(665.72 with post flag for individual item
+1 NEW ITM,DASTR
+2 ;check if FCP was posted for patient
+3 IF '$PIECE(^TMP($JOB,FCP,DFN),U,3)
QUIT
+4 KILL DIE,DA,DR
+5 SET DA(2)=VDR
SET DA(3)=RVDT
SET DA(4)=SITE
+6 SET DASTR=DA(4)_",1,"_DA(3)_",1,"_DA(2)_",""V"","
+7 SET ITM=""
FOR
SET ITM=$ORDER(^TMP($JOB,FCP,DFN,ITM))
if ITM=""
QUIT
Begin DoDot:1
+8 SET DA(1)=DFN
SET DIE="^RMPO(665.72,"_DASTR_DA(1)_",1,"
SET DR="8///Y"
SET DA=ITM
+9 DO ^DIE
End DoDot:1
+10 DO PATUPD
+11 ;ITMUPD
QUIT
+12 ;
PATUPD ;Update global ^RMPO(665.72 with post flag for patient
+1 NEW FLG,IT,X,PFLG,ISTR,DASTR
+2 KILL DIE,DA,DR
+3 SET DA(1)=DFN
SET DA(2)=VDR
SET DA(3)=RVDT
SET DA(4)=SITE
+4 SET IT=0
SET X=0
SET FLG="Y"
+5 FOR
SET IT=$ORDER(^RMPO(FIL,SITE,1,RVDT,1,VDR,"V",DFN,1,IT))
if 'IT
QUIT
Begin DoDot:1
+6 SET PFLG=$PIECE(^RMPO(FIL,SITE,1,RVDT,1,VDR,"V",DFN,1,IT,0),U,10)
+7 SET RP660=$PIECE(^RMPO(FIL,SITE,1,RVDT,1,VDR,"V",DFN,1,IT,0),U,16)
+8 IF '$GET(RP660)
SET FLG=""
+9 IF PFLG=""!(PFLG="N")
Begin DoDot:2
+10 IF PFLG=""
Begin DoDot:3
+11 SET DASTR=DA(4)_",1,"_DA(3)_",1,"_DA(2)_",""V"","_DA(1)_",1,"
+12 SET DIE="^RMPO(665.72,"_DASTR
SET DR="8///N"
SET DA=IT
DO ^DIE
End DoDot:3
+13 SET X=1
SET FLG="P"
End DoDot:2
QUIT
End DoDot:1
IF X
QUIT
+14 KILL DIE,DA,DR
+15 SET DA(1)=VDR
SET DA(2)=RVDT
SET DA(3)=SITE
SET DA=DFN
SET DR="3///"_FLG
+16 SET DIE="^RMPO(665.72,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",""V"","
+17 DO ^DIE
+18 ;PATUPD
QUIT
+19 ;
FCPUPD ;Update global ^RMPO(665.72 with totals for Purchase Card
+1 KILL DIE,DA,DR
+2 SET DA=IENFCP
SET DA(1)=RVDT
SET DA(2)=SITE
+3 SET DIE="^RMPO(665.72,"_DA(2)_",1,"_DA(1)_",2,"
+4 SET DR=$SELECT($PIECE(PAYINF,U)="P":"6///"_(FCPTOT+PCTOT)_";",1:"")
+5 SET DR=DR_"4////"_DUZ_";"_"5///"_VDR
+6 DO ^DIE
+7 ;FCPUPD
QUIT
+8 ;
