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