RMPOPF ;HINES-FO/DDA - MAIN INTERFACE ROUTINE FOR PFSS AND HOME OXYGEN ;8/18/05
;;3.0;PROSTHETICS;**98**;Feb 09, 1996
EN ; ENTRY POINT FOR HOME OXYGEN BACKGROUND PROCESSING
; Loop on APNEW and APO cross-references.
D APNEW,APO
K RMPR6699,RMPRACCT,RMPRAPLR,RMPRDFN,RMPRDG1,RMPRDRG,RMPREVNT,RMPRHCPC,RMPRHCPT,RMPRIEN,RMPRITEM,RMPRPAR,RMPRPR1,RMPRPV1,RMPRPV2,RMPRRX,RMPRRXDT,RMPRRXEX,RMPRRXI,RMPRRXLP,RMPRSITE,RMPRSTAT,RMPRZCL
Q
APNEW ;Loop on file #665 APNEW cross-reference.
; Delete ITEM'S PFSS ACCOUNT REFERENCE associated with previous prescription date.
; Set PFSS ACCOUNT FLAG. This will trigger the background process to obtain a new
; PFSS ACCOUNT REFERENCE for the new prescription date.
S RMPRIEN=0
F S RMPRIEN=$O(^RMPR(665,"APNEW",1,RMPRIEN)) Q:RMPRIEN'>0 D
.; Check for valid prescription
.D VALIDRX
.I RMPRRXDT=0 D EXITNEW Q
.S RMPRITEM=0
.F S RMPRITEM=$O(^RMPR(665,RMPRIEN,"RMPOC",RMPRITEM)) Q:RMPRITEM'>0 D
..S DIE="^RMPR(665,"_RMPRIEN_",""RMPOC"","
..S DA(1)=RMPRIEN,DA=RMPRITEM
..S DR="101///@;100///1"
..D ^DIE
..K DIE,DA,DR
..Q
.D EXITNEW
Q
EXITNEW ; Remove the APNEW flag
S RMPRRX=0
F S RMPRRX=$O(^RMPR(665,"APNEW",1,RMPRIEN,RMPRRX)) Q:RMPRRX'>0 D
.S DIE="^RMPR(665,"_RMPRIEN_",""RMPOB"","
.S DA(1)=RMPRIEN,DA=RMPRRX
.S DR="100///@"
.D ^DIE
.K DIE,DA,DR
.Q
Q
APO ;Loop on file #665 APO cross-reference and gather data for GETACCT api.
S RMPRIEN=0
F S RMPRIEN=$O(^RMPR(665,"APO",1,RMPRIEN)) Q:RMPRIEN'>0 D GETACCT
Q
GETACCT ; ENTRY POINT TO SEND HOME OXYGEN ACCOUNT CREATION, PRE-CERTIFICATION
;OR UPDATE DATA TO OBTAIN A PFSS ACCOUNT REFERENCE.
; QUIT IF ALL VALID PRESCRIPTIONS HAVE EXPIRED.
D VALIDRX ; LOOP ON EACH ITEM
S RMPRITEM=0
F S RMPRITEM=$O(^RMPR(665,"APO",1,RMPRIEN,RMPRITEM)) Q:RMPRITEM'>0 D
.I RMPRRXDT=0 D Q
..; Remove APO Flag
..S DIE="^RMPR(665,"_RMPRIEN_",""RMPOC"","
..S DA(1)=RMPRIEN,DA=RMPRITEM
..S DR="100///@"
..D ^DIE
..K DIE,DA,DR
..Q
.S RMPRDFN=RMPRIEN
.S RMPRPAR=$P($G(^RMPR(665,RMPRIEN,"RMPOC",RMPRITEM,"PFSS")),"^",2)
.S:RMPRPAR="" RMPREVNT="A05"
.S:RMPRPAR'="" RMPREVNT="A08"
.S RMPRAPLR="GETACCT;RMPOPF"
.S RMPRPV1(2)="O"
.S RMPRSTA=$P($G(^RMPR(665,RMPRIEN,0)),"^",2)
.D GETSITE^RMPRPF1
.S RMPRPV1(3)=RMPRHLOC
.S RMPRPV1(7)=$P($G(^RMPR(665,RMPRIEN,"RMPOB",RMPRRXI,"PFSS")),"^",2)
.S RMPRPV1(44)=RMPRRXDT
.S RMPRPV2(8)=RMPRRXDT
.; INSURE HCPCS IS CODE SET VERSIONED
.S RMPRHCPC=$P($G(^RMPR(665,RMPRIEN,"RMPOC",RMPRITEM,0)),"^",7),RMPRHCDT=RMPRRXDT
.D PSASHCPC
.; If HCPCS version check fails then quit, but leave APO Flag intact for future processing.
.; The HCPCS should eventually be corrected.
.Q:RMPRVHC=0
.S RMPRPR1(3)=RMPRVHC
.S RMPRPR1(4)=RMPRTHC
.S RMPRPR1(6)="O"
.; INSURE ICD9 IS CODE SET VERSIONED
.S RMPRDRG=$P($G(^RMPR(665,RMPRIEN,"RMPOC",RMPRITEM,0)),"^",8)
.S:RMPRDRG'="" RMPRDRG=$$STATCHK^ICDAPIU($P($G(^ICD9(RMPRDRG,0)),"^"),RMPRRXDT)
.S RMPRDG1(1,3)=""
.S:$P(RMPRDRG,"^")=1 RMPRDG1(1,3)=$P(RMPRDRG,"^",2),RMPRDG1(1,6)="F"
.;ZCL SEGMENT TO GO HERE
.S RMPRZCL=""
.; FIELDS NOT YET ENTERED.
.; Call GETACCT api
.S RMPRACCT=$$GETACCT^IBBAPI(RMPRDFN,RMPRPAR,RMPREVNT,RMPRAPLR,.RMPRPV1,.RMPRPV2,.RMPRPR1,.RMPRDG1,.RMPRZCL)
.; Store PFSS ACCOUNT REFERENCE data and Delete the APO flag.
.S DIE="^RMPR(665,"_RMPRIEN_",""RMPOC"","
.S DA(1)=RMPRIEN,DA=RMPRITEM
.S DR="100///@;101///`"_RMPRACCT
.D ^DIE
.K DIE,DA,DR
.K RMPRDFN,RMPRPAR,RMPREVNT,RMPRAPLR,RMPRPV1,RMPRPV2,RMPRSTA,RMPRHLOC,RMPRHCPC,RMPRPR1,RMPRDRG,RMPRDG1,RMPRZCL,RMPRACCT,RMPRSTAT,RMPRCHDT,RMPRVHC,RMPRTHC,RMPREHC
.Q
EXITGET ;
K RMPRRXDT,RMPRRXI,RMPRITEM
Q
PSASHCPC ; determine correct HCPCS code to send based on PSAS HCPCS.
; UPON ENTRY RMPRHCPC = POINTER TO 661.1 AND RMPRHCDT = FILEMAN DATE
; Returns with RMPRVHC having the correct value to pass to IBB.
I RMPRHCPC="" S RMPREHC="A9900",RMPRTHC="HCPCS DELETED" G CHK
S RMPREHC=$P($G(^RMPR(661.1,RMPRHCPC,0)),"^")
S RMPRTHC=$P($G(^RMPR(661.1,RMPRHCPC,0)),"^",2)
CHK S RMPRSTAT=$$STATCHK^ICPTAPIU(RMPREHC,RMPRHCDT)
I ($A($E(RMPREHC,2,2))>64)!($P(RMPRSTAT,"^")=0) D
.S RMPREHC="A9900"
.S RMPRSTAT=$$STATCHK^ICPTAPIU(RMPREHC,RMPRHCDT)
.Q
I $P(RMPRSTAT,"^")=1 S RMPRVHC=$P(RMPRSTAT,"^",2) Q
S RMPRVHC=0
Q
VALIDRX ; GET ASSOCIATED RX MAKE SURE IT HAS NOT EXPIRED.
S (RMPRRXLP,RMPRRX,RMPRRXI,RMPRRXEX,RMPRRXDT)=0
F S RMPRRXLP=$O(^RMPR(665,RMPRIEN,"RMPOB","B",RMPRRXLP)) Q:RMPRRXLP'>0 D
.F S RMPRRX=$O(^RMPR(665,RMPRIEN,"RMPOB","B",RMPRRXLP,RMPRRX)) Q:RMPRRX'>0 D
..S:$P($G(^RMPR(665,RMPRIEN,"RMPOB",RMPRRX,0)),"^",3)'<DT RMPRRXEX=$P($G(^RMPR(665,RMPRIEN,"RMPOB",RMPRRX,0)),"^",3),RMPRRXDT=RMPRRXLP,RMPRRXI=RMPRRX
..Q
.Q
K RMPRRXLP,RMPRRX,RMPRRXEX
Q
ACCTCNCL ; ENTRY POINT TO SEND HOME OXYGEN ACCOUNT CANCELLATION DATA.
; THIS TAG IS CALLED AS A ONE-TIME TASKMAN TASK LOADED FROM ACCTTASK^PMPOPF.
; Input variables from TaskMan-
; RMPRDFN = DA (also DFN)
; RMPRRXDT = Home Oxygen Prescription date
; RMPRRXEN = Home Oxygen Prescription IEN
;
;CHECK IF HOME OXYGEN PRESCRIPTION SUB RECORD HAS BEEN DELETED.
; EXIT IF IT STILL EXISTS
G:$D(^RMPR(665,RMPRDFN,"RMPOB","B",RMPRRXDT,RMPRRXEN)) EXITCNCL
; THE RECORD WAS DELETED
; LOOP ON PATIENT'S ITEMS.
S RMPRITEM=0
F S RMPRITEM=$O(^RMPR(665,RMPRDFN,"RMPOC",RMPRITEM)) Q:RMPRITEM'>0 D CANCEL
EXITCNCL ;
K RMPRDFN,RMPRRXDT,RMPRRXEN,RMPRITEM
Q
CANCEL ; ENTRY POINT TO SEND HOME OXYGEN ACCOUNT CANCELLATION DATA.
; THIS TAG IS CALLED AS A ONE-TIME TASKMAN TASK LOADED FROM ITEMTASK^PMPOPF.
; Input variables from TaskMan-
; RMPRDFN = DA (also DFN)
; RMPRITEM = Home Oxygen Item IEN
;
;CHECK IF HOME OXYGEN PRESCRIPTION SUB RECORD HAS BEEN DELETED.
; EXIT IF IT STILL EXISTS
; SET FROM:
; RMPRDFN = DFN SENT WITHIN TASKMAN
; RMPRPAR = HOME OXYGEN ITEM (19.4); PFSS Account Reference (101)
; RMPREVNT = "A38"
; RMPRAPLR = "CANCEL1;RMPOPF"
; RMPRPV1(2) = "O"
; RMPRPV1(3) = FILE 669.9, FIELD 52
; RMPRPV1(44) = THE HOME OXYGEN PRESCRIPTION DATE SENT WITHIN TASKMAN
S RMPRPAR=$P($G(^RMPR(665,RMPRDFN,"RMPOC",RMPRITEM,"PFSS")),"^",2)
CANCEL1 ; ENTRY POINT FOR SINGLE ITEM DELETE (ITEMTASK)
S RMPREVNT="A38"
S RMPRAPLR="CANCEL1;RMPOPF"
S RMPRPV1(2)="O"
S RMPRSTA=$P($G(^RMPR(665,RMPRDFN,0)),"^",2)
D GETSITE^RMPRPF1
S RMPRPV1(3)=RMPRHLOC
S RMPRIEN=RMPRDFN D VALIDRX
S:RMPRRXDT'=0 RMPRPV1(44)=RMPRRXDT
; SEND A38 GETACCT FOR THE ITEM
S RMPRCNCL=$$GETACCT^IBBAPI(RMPRDFN,RMPRPAR,RMPREVNT,RMPRAPLR,.RMPRPV1)
K RMPRPAR,RMPREVNT,RMPRAPLR,RMPRPV1,RMPRSTA,RMPRHLOC,RMPRCNCL
Q
ACCTTASK ; FILE #665, HOME OXYGEN PRESCRITION; DATE FIELD MUMPS XREF KILL LOGIC.
; TASKMAN LOAD A ONE TIME TASKMAN TASK.
Q:'+$$SWSTAT^IBBAPI()
N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC
S ZTIO="",ZTRTN="ACCTCNCL^RMPOPF",ZTDESC="Prosthetics Home Oxygen PFSS Account Cancel",ZTDTH=$H
S ZTSAVE("RMPRDFN")=DA(1),ZTSAVE("RMPRRXEN")=DA,ZTSAVE("RMPRRXDT")=X
D ^%ZTLOAD
Q
ITEMTASK ; FILE #665, HOME OXYGEN ITEM; ITEM FIELD MUMPS XREF
;KILL LOGIC.
; TASKMAN LOAD A ONE TIME TASKMAN TASK.
Q:'+$$SWSTAT^IBBAPI()
S RMPRPAR=$P($G(^RMPR(665,DA(1),"RMPOC",DA,"PFSS")),"^",2)
N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC
S ZTIO="",ZTRTN="CANCEL1^RMPOPF",ZTDESC="Prosthetics Home Oxygen PFSS Item Cancel",ZTDTH=$H
S ZTSAVE("RMPRDFN")=DA(1),ZTSAVE("RMPRITEM")=DA,ZTSAVE("RMPRPAR")=RMPRPAR
D ^%ZTLOAD
K RMPRPAR
Q
CHRGTASK ; FILE #665.72, BILLING MONTH; VENDOR; PATIENT; ITEM FIELD MUMPS XREF
;KILL LOGIC.
; TASKMAN LOAD A ONE TIME TASKMAN TASK.
Q:'+$$SWSTAT^IBBAPI()
S RMPRPFSS=^RMPO(665.72,DA(4),1,DA(3),1,DA(2),"V",DA(1),1,DA,"PFSS")
N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC
S ZTIO="",ZTRTN="CHRGCRED^RMPOPF1",ZTDESC="Prosthetics Home Oxygen PFSS Charge Credit",ZTDTH=$H
S ZTSAVE("RMPRDFN")=DA(1),ZTSAVE("RMPRITEM")=DA,ZTSAVE("RMPRVDR")=DA(2),ZTSAVE("RMPRBLDT")=DA(3),ZTSAVE("RMPRSITE")=DA(4)
S ZTSAVE("RMPRPFSS")=^RMPO(665.72,DA(4),1,DA(3),1,DA(2),"V",DA(1),1,DA,"PFSS")
D ^%ZTLOAD
Q
CHARGE ; Called from RMPOPST3.
;IMPORTANT VARIBLES PASSED IN FROM RMPOPST3.
; D6I= FILE 660 IEN
; RMPOXITE= FILE 665.72 SITE (IEN)
; RMPODATE= FILE 665.72 BILLING MONTH mult IEN
; RMPOVDR= FILE 665.72 VENDOR mult IEN (DINUM to 440)
; DFN= FILE 665.72 PATIENT mult IEN (DINUM to 2)
; ITM= FILE 665.72 ITEM mult IEN
; TRXDT= Date TRX Built
; ITMD= Item multiple zero node
;
Q:'+$$SWSTAT^IBBAPI()
D CHARGE^RMPOPF1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOPF 8595 printed Sep 23, 2025@20:07:27 Page 2
RMPOPF ;HINES-FO/DDA - MAIN INTERFACE ROUTINE FOR PFSS AND HOME OXYGEN ;8/18/05
+1 ;;3.0;PROSTHETICS;**98**;Feb 09, 1996
EN ; ENTRY POINT FOR HOME OXYGEN BACKGROUND PROCESSING
+1 ; Loop on APNEW and APO cross-references.
+2 DO APNEW
DO APO
+3 KILL RMPR6699,RMPRACCT,RMPRAPLR,RMPRDFN,RMPRDG1,RMPRDRG,RMPREVNT,RMPRHCPC,RMPRHCPT,RMPRIEN,RMPRITEM,RMPRPAR,RMPRPR1,RMPRPV1,RMPRPV2,RMPRRX,RMPRRXDT,RMPRRXEX,RMPRRXI,RMPRRXLP,RMPRSITE,RMPRSTAT,RMPRZCL
+4 QUIT
APNEW ;Loop on file #665 APNEW cross-reference.
+1 ; Delete ITEM'S PFSS ACCOUNT REFERENCE associated with previous prescription date.
+2 ; Set PFSS ACCOUNT FLAG. This will trigger the background process to obtain a new
+3 ; PFSS ACCOUNT REFERENCE for the new prescription date.
+4 SET RMPRIEN=0
+5 FOR
SET RMPRIEN=$ORDER(^RMPR(665,"APNEW",1,RMPRIEN))
if RMPRIEN'>0
QUIT
Begin DoDot:1
+6 ; Check for valid prescription
+7 DO VALIDRX
+8 IF RMPRRXDT=0
DO EXITNEW
QUIT
+9 SET RMPRITEM=0
+10 FOR
SET RMPRITEM=$ORDER(^RMPR(665,RMPRIEN,"RMPOC",RMPRITEM))
if RMPRITEM'>0
QUIT
Begin DoDot:2
+11 SET DIE="^RMPR(665,"_RMPRIEN_",""RMPOC"","
+12 SET DA(1)=RMPRIEN
SET DA=RMPRITEM
+13 SET DR="101///@;100///1"
+14 DO ^DIE
+15 KILL DIE,DA,DR
+16 QUIT
End DoDot:2
+17 DO EXITNEW
End DoDot:1
+18 QUIT
EXITNEW ; Remove the APNEW flag
+1 SET RMPRRX=0
+2 FOR
SET RMPRRX=$ORDER(^RMPR(665,"APNEW",1,RMPRIEN,RMPRRX))
if RMPRRX'>0
QUIT
Begin DoDot:1
+3 SET DIE="^RMPR(665,"_RMPRIEN_",""RMPOB"","
+4 SET DA(1)=RMPRIEN
SET DA=RMPRRX
+5 SET DR="100///@"
+6 DO ^DIE
+7 KILL DIE,DA,DR
+8 QUIT
End DoDot:1
+9 QUIT
APO ;Loop on file #665 APO cross-reference and gather data for GETACCT api.
+1 SET RMPRIEN=0
+2 FOR
SET RMPRIEN=$ORDER(^RMPR(665,"APO",1,RMPRIEN))
if RMPRIEN'>0
QUIT
DO GETACCT
+3 QUIT
GETACCT ; ENTRY POINT TO SEND HOME OXYGEN ACCOUNT CREATION, PRE-CERTIFICATION
+1 ;OR UPDATE DATA TO OBTAIN A PFSS ACCOUNT REFERENCE.
+2 ; QUIT IF ALL VALID PRESCRIPTIONS HAVE EXPIRED.
+3 ; LOOP ON EACH ITEM
DO VALIDRX
+4 SET RMPRITEM=0
+5 FOR
SET RMPRITEM=$ORDER(^RMPR(665,"APO",1,RMPRIEN,RMPRITEM))
if RMPRITEM'>0
QUIT
Begin DoDot:1
+6 IF RMPRRXDT=0
Begin DoDot:2
+7 ; Remove APO Flag
+8 SET DIE="^RMPR(665,"_RMPRIEN_",""RMPOC"","
+9 SET DA(1)=RMPRIEN
SET DA=RMPRITEM
+10 SET DR="100///@"
+11 DO ^DIE
+12 KILL DIE,DA,DR
+13 QUIT
End DoDot:2
QUIT
+14 SET RMPRDFN=RMPRIEN
+15 SET RMPRPAR=$PIECE($GET(^RMPR(665,RMPRIEN,"RMPOC",RMPRITEM,"PFSS")),"^",2)
+16 if RMPRPAR=""
SET RMPREVNT="A05"
+17 if RMPRPAR'=""
SET RMPREVNT="A08"
+18 SET RMPRAPLR="GETACCT;RMPOPF"
+19 SET RMPRPV1(2)="O"
+20 SET RMPRSTA=$PIECE($GET(^RMPR(665,RMPRIEN,0)),"^",2)
+21 DO GETSITE^RMPRPF1
+22 SET RMPRPV1(3)=RMPRHLOC
+23 SET RMPRPV1(7)=$PIECE($GET(^RMPR(665,RMPRIEN,"RMPOB",RMPRRXI,"PFSS")),"^",2)
+24 SET RMPRPV1(44)=RMPRRXDT
+25 SET RMPRPV2(8)=RMPRRXDT
+26 ; INSURE HCPCS IS CODE SET VERSIONED
+27 SET RMPRHCPC=$PIECE($GET(^RMPR(665,RMPRIEN,"RMPOC",RMPRITEM,0)),"^",7)
SET RMPRHCDT=RMPRRXDT
+28 DO PSASHCPC
+29 ; If HCPCS version check fails then quit, but leave APO Flag intact for future processing.
+30 ; The HCPCS should eventually be corrected.
+31 if RMPRVHC=0
QUIT
+32 SET RMPRPR1(3)=RMPRVHC
+33 SET RMPRPR1(4)=RMPRTHC
+34 SET RMPRPR1(6)="O"
+35 ; INSURE ICD9 IS CODE SET VERSIONED
+36 SET RMPRDRG=$PIECE($GET(^RMPR(665,RMPRIEN,"RMPOC",RMPRITEM,0)),"^",8)
+37 if RMPRDRG'=""
SET RMPRDRG=$$STATCHK^ICDAPIU($PIECE($GET(^ICD9(RMPRDRG,0)),"^"),RMPRRXDT)
+38 SET RMPRDG1(1,3)=""
+39 if $PIECE(RMPRDRG,"^")=1
SET RMPRDG1(1,3)=$PIECE(RMPRDRG,"^",2)
SET RMPRDG1(1,6)="F"
+40 ;ZCL SEGMENT TO GO HERE
+41 SET RMPRZCL=""
+42 ; FIELDS NOT YET ENTERED.
+43 ; Call GETACCT api
+44 SET RMPRACCT=$$GETACCT^IBBAPI(RMPRDFN,RMPRPAR,RMPREVNT,RMPRAPLR,.RMPRPV1,.RMPRPV2,.RMPRPR1,.RMPRDG1,.RMPRZCL)
+45 ; Store PFSS ACCOUNT REFERENCE data and Delete the APO flag.
+46 SET DIE="^RMPR(665,"_RMPRIEN_",""RMPOC"","
+47 SET DA(1)=RMPRIEN
SET DA=RMPRITEM
+48 SET DR="100///@;101///`"_RMPRACCT
+49 DO ^DIE
+50 KILL DIE,DA,DR
+51 KILL RMPRDFN,RMPRPAR,RMPREVNT,RMPRAPLR,RMPRPV1,RMPRPV2,RMPRSTA,RMPRHLOC,RMPRHCPC,RMPRPR1,RMPRDRG,RMPRDG1,RMPRZCL,RMPRACCT,RMPRSTAT,RMPRCHDT,RMPRVHC,RMPRTHC,RMPREHC
+52 QUIT
End DoDot:1
EXITGET ;
+1 KILL RMPRRXDT,RMPRRXI,RMPRITEM
+2 QUIT
PSASHCPC ; determine correct HCPCS code to send based on PSAS HCPCS.
+1 ; UPON ENTRY RMPRHCPC = POINTER TO 661.1 AND RMPRHCDT = FILEMAN DATE
+2 ; Returns with RMPRVHC having the correct value to pass to IBB.
+3 IF RMPRHCPC=""
SET RMPREHC="A9900"
SET RMPRTHC="HCPCS DELETED"
GOTO CHK
+4 SET RMPREHC=$PIECE($GET(^RMPR(661.1,RMPRHCPC,0)),"^")
+5 SET RMPRTHC=$PIECE($GET(^RMPR(661.1,RMPRHCPC,0)),"^",2)
CHK SET RMPRSTAT=$$STATCHK^ICPTAPIU(RMPREHC,RMPRHCDT)
+1 IF ($ASCII($EXTRACT(RMPREHC,2,2))>64)!($PIECE(RMPRSTAT,"^")=0)
Begin DoDot:1
+2 SET RMPREHC="A9900"
+3 SET RMPRSTAT=$$STATCHK^ICPTAPIU(RMPREHC,RMPRHCDT)
+4 QUIT
End DoDot:1
+5 IF $PIECE(RMPRSTAT,"^")=1
SET RMPRVHC=$PIECE(RMPRSTAT,"^",2)
QUIT
+6 SET RMPRVHC=0
+7 QUIT
VALIDRX ; GET ASSOCIATED RX MAKE SURE IT HAS NOT EXPIRED.
+1 SET (RMPRRXLP,RMPRRX,RMPRRXI,RMPRRXEX,RMPRRXDT)=0
+2 FOR
SET RMPRRXLP=$ORDER(^RMPR(665,RMPRIEN,"RMPOB","B",RMPRRXLP))
if RMPRRXLP'>0
QUIT
Begin DoDot:1
+3 FOR
SET RMPRRX=$ORDER(^RMPR(665,RMPRIEN,"RMPOB","B",RMPRRXLP,RMPRRX))
if RMPRRX'>0
QUIT
Begin DoDot:2
+4 if $PIECE($GET(^RMPR(665,RMPRIEN,"RMPOB",RMPRRX,0)),"^",3)'<DT
SET RMPRRXEX=$PIECE($GET(^RMPR(665,RMPRIEN,"RMPOB",RMPRRX,0)),"^",3)
SET RMPRRXDT=RMPRRXLP
SET RMPRRXI=RMPRRX
+5 QUIT
End DoDot:2
+6 QUIT
End DoDot:1
+7 KILL RMPRRXLP,RMPRRX,RMPRRXEX
+8 QUIT
ACCTCNCL ; ENTRY POINT TO SEND HOME OXYGEN ACCOUNT CANCELLATION DATA.
+1 ; THIS TAG IS CALLED AS A ONE-TIME TASKMAN TASK LOADED FROM ACCTTASK^PMPOPF.
+2 ; Input variables from TaskMan-
+3 ; RMPRDFN = DA (also DFN)
+4 ; RMPRRXDT = Home Oxygen Prescription date
+5 ; RMPRRXEN = Home Oxygen Prescription IEN
+6 ;
+7 ;CHECK IF HOME OXYGEN PRESCRIPTION SUB RECORD HAS BEEN DELETED.
+8 ; EXIT IF IT STILL EXISTS
+9 if $DATA(^RMPR(665,RMPRDFN,"RMPOB","B",RMPRRXDT,RMPRRXEN))
GOTO EXITCNCL
+10 ; THE RECORD WAS DELETED
+11 ; LOOP ON PATIENT'S ITEMS.
+12 SET RMPRITEM=0
+13 FOR
SET RMPRITEM=$ORDER(^RMPR(665,RMPRDFN,"RMPOC",RMPRITEM))
if RMPRITEM'>0
QUIT
DO CANCEL
EXITCNCL ;
+1 KILL RMPRDFN,RMPRRXDT,RMPRRXEN,RMPRITEM
+2 QUIT
CANCEL ; ENTRY POINT TO SEND HOME OXYGEN ACCOUNT CANCELLATION DATA.
+1 ; THIS TAG IS CALLED AS A ONE-TIME TASKMAN TASK LOADED FROM ITEMTASK^PMPOPF.
+2 ; Input variables from TaskMan-
+3 ; RMPRDFN = DA (also DFN)
+4 ; RMPRITEM = Home Oxygen Item IEN
+5 ;
+6 ;CHECK IF HOME OXYGEN PRESCRIPTION SUB RECORD HAS BEEN DELETED.
+7 ; EXIT IF IT STILL EXISTS
+8 ; SET FROM:
+9 ; RMPRDFN = DFN SENT WITHIN TASKMAN
+10 ; RMPRPAR = HOME OXYGEN ITEM (19.4); PFSS Account Reference (101)
+11 ; RMPREVNT = "A38"
+12 ; RMPRAPLR = "CANCEL1;RMPOPF"
+13 ; RMPRPV1(2) = "O"
+14 ; RMPRPV1(3) = FILE 669.9, FIELD 52
+15 ; RMPRPV1(44) = THE HOME OXYGEN PRESCRIPTION DATE SENT WITHIN TASKMAN
+16 SET RMPRPAR=$PIECE($GET(^RMPR(665,RMPRDFN,"RMPOC",RMPRITEM,"PFSS")),"^",2)
CANCEL1 ; ENTRY POINT FOR SINGLE ITEM DELETE (ITEMTASK)
+1 SET RMPREVNT="A38"
+2 SET RMPRAPLR="CANCEL1;RMPOPF"
+3 SET RMPRPV1(2)="O"
+4 SET RMPRSTA=$PIECE($GET(^RMPR(665,RMPRDFN,0)),"^",2)
+5 DO GETSITE^RMPRPF1
+6 SET RMPRPV1(3)=RMPRHLOC
+7 SET RMPRIEN=RMPRDFN
DO VALIDRX
+8 if RMPRRXDT'=0
SET RMPRPV1(44)=RMPRRXDT
+9 ; SEND A38 GETACCT FOR THE ITEM
+10 SET RMPRCNCL=$$GETACCT^IBBAPI(RMPRDFN,RMPRPAR,RMPREVNT,RMPRAPLR,.RMPRPV1)
+11 KILL RMPRPAR,RMPREVNT,RMPRAPLR,RMPRPV1,RMPRSTA,RMPRHLOC,RMPRCNCL
+12 QUIT
ACCTTASK ; FILE #665, HOME OXYGEN PRESCRITION; DATE FIELD MUMPS XREF KILL LOGIC.
+1 ; TASKMAN LOAD A ONE TIME TASKMAN TASK.
+2 if '+$$SWSTAT^IBBAPI()
QUIT
+3 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC
+4 SET ZTIO=""
SET ZTRTN="ACCTCNCL^RMPOPF"
SET ZTDESC="Prosthetics Home Oxygen PFSS Account Cancel"
SET ZTDTH=$HOROLOG
+5 SET ZTSAVE("RMPRDFN")=DA(1)
SET ZTSAVE("RMPRRXEN")=DA
SET ZTSAVE("RMPRRXDT")=X
+6 DO ^%ZTLOAD
+7 QUIT
ITEMTASK ; FILE #665, HOME OXYGEN ITEM; ITEM FIELD MUMPS XREF
+1 ;KILL LOGIC.
+2 ; TASKMAN LOAD A ONE TIME TASKMAN TASK.
+3 if '+$$SWSTAT^IBBAPI()
QUIT
+4 SET RMPRPAR=$PIECE($GET(^RMPR(665,DA(1),"RMPOC",DA,"PFSS")),"^",2)
+5 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC
+6 SET ZTIO=""
SET ZTRTN="CANCEL1^RMPOPF"
SET ZTDESC="Prosthetics Home Oxygen PFSS Item Cancel"
SET ZTDTH=$HOROLOG
+7 SET ZTSAVE("RMPRDFN")=DA(1)
SET ZTSAVE("RMPRITEM")=DA
SET ZTSAVE("RMPRPAR")=RMPRPAR
+8 DO ^%ZTLOAD
+9 KILL RMPRPAR
+10 QUIT
CHRGTASK ; FILE #665.72, BILLING MONTH; VENDOR; PATIENT; ITEM FIELD MUMPS XREF
+1 ;KILL LOGIC.
+2 ; TASKMAN LOAD A ONE TIME TASKMAN TASK.
+3 if '+$$SWSTAT^IBBAPI()
QUIT
+4 SET RMPRPFSS=^RMPO(665.72,DA(4),1,DA(3),1,DA(2),"V",DA(1),1,DA,"PFSS")
+5 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC
+6 SET ZTIO=""
SET ZTRTN="CHRGCRED^RMPOPF1"
SET ZTDESC="Prosthetics Home Oxygen PFSS Charge Credit"
SET ZTDTH=$HOROLOG
+7 SET ZTSAVE("RMPRDFN")=DA(1)
SET ZTSAVE("RMPRITEM")=DA
SET ZTSAVE("RMPRVDR")=DA(2)
SET ZTSAVE("RMPRBLDT")=DA(3)
SET ZTSAVE("RMPRSITE")=DA(4)
+8 SET ZTSAVE("RMPRPFSS")=^RMPO(665.72,DA(4),1,DA(3),1,DA(2),"V",DA(1),1,DA,"PFSS")
+9 DO ^%ZTLOAD
+10 QUIT
CHARGE ; Called from RMPOPST3.
+1 ;IMPORTANT VARIBLES PASSED IN FROM RMPOPST3.
+2 ; D6I= FILE 660 IEN
+3 ; RMPOXITE= FILE 665.72 SITE (IEN)
+4 ; RMPODATE= FILE 665.72 BILLING MONTH mult IEN
+5 ; RMPOVDR= FILE 665.72 VENDOR mult IEN (DINUM to 440)
+6 ; DFN= FILE 665.72 PATIENT mult IEN (DINUM to 2)
+7 ; ITM= FILE 665.72 ITEM mult IEN
+8 ; TRXDT= Date TRX Built
+9 ; ITMD= Item multiple zero node
+10 ;
+11 if '+$$SWSTAT^IBBAPI()
QUIT
+12 DO CHARGE^RMPOPF1
+13 QUIT
