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