RMPOPED ;EDS/MDB,DDW,RVD - HOME OXYGEN MISC FILE EDITS ;7/24/98
;;3.0;PROSTHETICS;**29,44,41,52,77,110,140,148,168,180,207**;Feb 09, 1996;Build 15
;
; Reference to $$SINFO^ICDEX supported by ICR #5747
; Reference to $$CSI^ICDEX supported by ICR #5747
; Reference to $$ICDDX^ICDEX supported by ICR #5747
; Reference to $$VLT^ICDEX supported by ICR #5747
; Reference to $$CODEC^ICDEX supported by ICR #5747
; Reference to $$LS^ICDEX supported by ICR #5747
;
; HNC - patch 52
; modified SITECHK sub
; X will be undefined from GETS^DIQ if field is null
; added $G.
; RVD - patch #77 use FileMan to set items that are not Primary item
; to 'N' in order to set correctly the 'AC' cross-ref.
;
; RGB - PATCH 180 When HCPCS code displays inactive message the user
; will now be required to use an active code
;
; RGB - PATCH 207 Allow expiration date to print with script dates
Q
UNLOCK I $D(RMPODFN) L -^RMPR(665,RMPODFN)
Q
EXIT K DIC,DIE,DIR,DIK,X,Y,Z,DR,DA,DD,DO,D0,DTOUT,DIROUT,DUOUT,DIRUT,QUIT,DFN,ITEM,ITEMS,IEN,IENS,ITMACT,ITM,C,S,W,PI,VDR,ZST
D UNLOCK
Q
;
KEY ;user must have the RMPRSUPERVISOR key in order to add a new patient.
;option name is EDIT HOME OXYGEN PATIENT
N KEY
S KEY=$O(^DIC(19.1,"B","RMPRSUPERVISOR",0))
I '$D(^VA(200,DUZ,51,KEY)) D Q
. W !!,"You do not hold the RMPRSUPERVISOR key!!"
G PAT
;
SITE ; Editing of Home Oxygen site parameter file.
K DIC,DIE,DA,DR,DD,RMPOXITE
S DIC="^RMPR(669.9,",DIC(0)="QEAMLZ",DIC("A")="Select SITE: "
D ^DIC Q:Y<0!$$QUIT
K DIC("A")
S (DA,RMPOXITE)=+Y
; Lock it...
L +^RMPR(669.9,RMPOXITE):2
I '$T D G SITE
. W ?10,$C(7)_Y(0,0)_" -- record in use. Try again later."
; Edit it
S DIE=DIC,DR="60;61;62;65" D ^DIE Q:$$EQUIT
; Edit FCP
K DIC,DA,DD,DR,DIE
;
; Done. Unlock
L -^RMPR(669.9,RMPOXITE)
G SITE
;
FCPHLP ; Executable help for FCP multiple in 669.9
;
Q
FCPIX ; Input transform for FCP multiple in 669.9
;
Q:'$D(X)
I $L(X)>30!($L(X)<3) K X Q
S ZST=$P(^RMPR(669.9,D0,4),U,1),RMPOX=X
D FIND^DIC(420.01,","_ZST_",",".01;","M",X,1,,,,"X")
S X=$S($D(X("DILIST","ID",1,.01)):X("DILIST","ID",1,.01),1:RMPOX)
K X("DILIST"),RMPOX
I $G(ZST),('$D(^PRC(420,+ZST,1,"B",X))) W !,"Control Point is not a valid IFCAP FCP.." K X
Q
ACT ;activate/inactivate a home oxygen patient
;Set up site variables.
D HOSITE^RMPOUTL0 I QUIT D EXIT Q
W @IOF
;
ACT1 ;Toggle ACTIVATE/INACTIVATE functions.
N NAME K DIC,DA
S DIC="^RMPR(665,",DIC(0)="QEAMZ" D ^DIC I Y<0!$$QUIT D EXIT Q
S DIE=DIC,DA=+Y,NAME=Y(0,0)
L +^RMPR(665,DA):2
I '$T D G ACT1
. W ?10,$C(7)_Y(0,0)_" -- record in use. Try later."
;If the patient has never been activated, quit.
I $P($G(^RMPR(665,DA,"RMPOA")),U,2)="" D G ACT1
. W !!,$C(7)_NAME_" has not been added as a Home Oxygen patient."
. W !,"Please add using the ""Add/Edit Home Oxygen Patient"" option."
;If the patient is active, perform inactivation actions.
I $P($G(^RMPR(665,DA,"RMPOA")),U,3)="" D INACTVT^RMPOPED G ACT1
;If the patient is inactive, perform activation actions.
I $P($G(^RMPR(665,DA,"RMPOA")),U,3)'="" D ACTVT^RMPOPED G ACT1
Q
INACTVT ; Inactivate the patient if user wants to.
; Confirm if the user wants to proceed.
K DIR S DIR(0)="YO",DIR("B")="NO"
S DIR("A")="Are you sure you want to inactivate "_NAME_" ?" D ^DIR
Q:(Y<1)!$$QUIT
S DR="19.5//TODAY;19.6;19.7////"_DUZ,DIE("NO^")="BACK"
D ^DIE
Q
;
ACTVT ;Activate the patient if the user wants to.
K DIR S DIR(0)="YO",DIR("B")="NO"
S DIR("A")="Are you sure you want to reactivate "_NAME_" ?" D ^DIR
Q:(Y<1)!$$QUIT
S DR="19.2//TODAY;19.5///@;19.6///@;19.7///@"
S DIE("NO^")="BACK"
D ^DIE
Q
PAT ;Add/Edit Home Oxygen Patient
S QUIT=0
D HOSITE^RMPOUTL0
I '$D(RMPOXITE)!QUIT D EXIT Q
LOOP ;
S QUIT=0
D LOOKUP I QUIT!'$D(RMPODFN) D EXIT Q
D EDBLK I QUIT D EXIT Q
D UNLOCK G LOOP
EDBLK ;
D SITECHK Q:QUIT
N RMPRDOI ; ICD - Date of Interest
N RMPRWARN ; Flag if Prescription/Item mismatch was issued
N RMPRCONT ; Flag if user wanted to continue after warning was issued
S (RMPRWARN,RMPRCONT,RMPRDOI)=""
D DEMOG Q:QUIT
D RX Q:QUIT
Q:+RMPRDOI'>0
D ITEM
Q
;called by ^RMPOBIL1, providing RMPOPATN as the X variable
EDIT ;From Billing...
I '$D(RMPODFN) S RMPODFN=$TR($G(RMPOPATN),"`")
Q:'$D(^RMPR(665,+RMPODFN,0))
W !,"EDITING "_$P(^DPT(RMPODFN,0),U)_"...",!
S QUIT=0,DA=RMPODFN
L +^RMPR(665,DA):2
I '$T W !!?10,*7," << Record in use. Try later. >>" Q
D EDBLK,EXIT
Q
LOOKUP ;First look-up the patient
K DIC,DIE,DA,DR,RMPODFN
W !!! S DIC="^RMPR(665,",DIC(0)="LQEAMZ"
D ^DIC Q:(Y<0)!$$QUIT
CONT S (RMPODFN,DA)=+Y
L +^RMPR(665,DA):2
I '$T W !!?10,*7," << Record in use. Try later. >>" G LOOKUP
Q
;
QUIT() S QUIT=$G(QUIT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q QUIT
EQUIT() S QUIT=$D(DTOUT)!$D(Y) Q QUIT
LJ(S,W,C) ; LEFT JUSTIFY S IN A FIELD W WIDE PADDING WITH CHAR F
;
S C=$G(C," ") ;DEFAULT PAD CHAR IS SPACE
S $P(S,C,W-$L(S)+$L(S,C))=""
Q S
;
SITECHK ;If user chooses patient from site different from billing site
;
S Y=$P($G(^RMPR(665,RMPODFN,"RMPOA")),U,7)
Q:Y=RMPOXITE ;Site is the same..
I Y="" D SET Q ;Site not defined, stuff RMPOXITE...
; Site is different...
S IENS=RMPODFN_","
D GETS^DIQ(665,IENS,19.12,"E","X")
W !!,"Patient's Home Oxygen Contract Location (HOCL) is "
W $G(X(665,IENS,19.12,"E"))
W !,"You are working on billing for HOCL "_RMPO("NAME"),!
K DIR S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Should I change this patient's HOCL to "_RMPO("NAME")
D ^DIR Q:$$QUIT!(Y=0)
D SET
Q
SET ;
K DIE,DR,DA
S DA=RMPODFN
S DIE="^RMPR(665,",DR="19.12////"_RMPOXITE D ^DIE
Q
;
DEMOG ;First edit the patient's basic fields
;
K DIE,DR,DA
S DA=RMPODFN
S DIE="^RMPR(665,",DR="19.1" D ^DIE Q:$$EQUIT
S RMPOELIG=$P($G(^RMPR(665,RMPODFN,"RMPOA")),U)
K DR S DR="19.11"_$S(RMPOELIG="D":"",1:"///@")_";19.12"
D ^DIE Q:$$EQUIT
K DR S Y=DT X ^DD("DD") S DR="19.2//"_Y D ^DIE Q:$$QUIT
Q
;
RX ;Edit the Rx Data
;
N RXD,RXDI,RMPRIENS
K DIC,DIE,DA,DR
S DIC("W")="N C,DINAME W "" "" W "" "",$$NAKED^DIUTL(""$$DATE^DIUTL($P(^(0),U,3))"")"
S DIC="^RMPR(665,"_RMPODFN_",""RMPOB"",",DIC(0)="AEQLZ"
S DA(1)=RMPODFN,DIC("P")="665.193D"
S RXD=$O(^RMPR(665,DA(1),"RMPOB","B",""),-1) D:RXD
. S DIC("B")=$$FMTE^XLFDT(RXD)
D ^DIC Q:Y<0!$$QUIT
; Set RMPRIENS for loading Date of Interest after final edits
S RMPRIENS=+Y_","_DA(1)_","
; Edit START DATE (#.01), EXPIRATION DATE (#2) and DESCRIPTION (#3)
S DIE=DIC,DA=+Y,DR=".01;2//^D EXPIRE^RMPOBIL4;3" D ^DIE Q:$$EQUIT
; Load ICD Date of Interest
S RMPRDOI=$$GET1^DIQ(665.193,RMPRIENS,.01,"I",,)
Q
;
ITEM ;Add/Edit Items
;
; Display items
D ITEMD
; If no items on file, then only allow ADD PRIMARY ITEM
I '$D(IEN) D ITEMP Q:QUIT!(ITEM="") G ITEM
; ask for ACTION, quit if <return>, timeout, etc
S ITMACT=$$ITEMO Q:$$QUIT!(ITMACT="")
; if they entered 'A', do ADD ITEM, then edit it
I ITMACT="A" D ITEMA Q:QUIT!(ITEM="") D ITEME Q:QUIT G ITEM
; if they entered 'D', select an item, then delete it
I ITMACT="D" D ITEMS Q:QUIT!(ITEM="") D ITEMK G ITEM
; if they entered 'E', select an item, then edit it
I ITMACT="E" D ITEMS
; If warning issued and Continue = No
I RMPRWARN=1,RMPRCONT'=1 S (RMPRWARN,RMPRCONT)="" G ITEM
Q:QUIT!(ITEM="")
D ITEME Q:QUIT
G ITEM
Q
;
ITEMP ; Add Primary Item
W !!,$C(7)_"No items found, please enter PRIMARY ITEM",!
D ITEMA Q:QUIT!(ITEM="")
S PI="///Y" D ITEME K PI
Q
ITEMA ; Add Items
S ITEM=""
K DIC S DIC="^RMPR(661,",DIC(0)="AEQMZ" D ^DIC Q:Y<0!$$QUIT
K DD,DO,DA,DIC
S DIC="^RMPR(665,"_RMPODFN_",""RMPOC"",",DIC(0)="L"
S DIC("P")=$P(^DD(665,19.4,0),U,2),DA(1)=RMPODFN,X=+Y
D FILE^DICN I Y>0 S IEN=$G(IEN)+1,IEN(IEN)=+Y,ITEM=IEN
Q
;
ITEMS ; Select Item
; Return ITEM = index into both ITEMS and IEN arrays
N RMPRQUIT,RMPRACS,RMPRCS,RMPRICD,RMPRICS,RMPRANS,RMPRACT
; Determine Active Coding System based on Date of Interest
S RMPRACS=$$SINFO^ICDEX("DIAG",RMPRDOI) ; Supported by ICR 5747
S RMPRACS=$P(RMPRACS,U,2),RMPRACS=$P(RMPRACS,"-",2)
; If only one Item on file
I IEN=1 S ITEM=1 W " ",$E(ITEMS(1),1,33) Q:ITMACT'="E" D Q
.; Load Item info
.D RMPRLOAD
.; If item has an ICD code, verify that it was active based on
.; start date of currently selected prescription.
.I RMPRICD'="",RMPRACT'="+" D
..; Display warning
..D RMPRWARN^RMPOPED1(RMPRICD,RMPRACS,RMPODFN,.ITEM,.RMPRCONT)
..S RMPRWARN=1 ; Set warning issued flag
; If multiple items on file
K DIR
S ITEM=""
S DIR(0)="NO^1:"_IEN,DIR("A")="Select an ITEM"
S DIR("?")="Select an item from the list"
M DIR("?")=ITEMS
F D Q:RMPRQUIT=1
.S RMPRQUIT=""
.D ^DIR
.I Y'>0 S RMPRQUIT=1,ITEM="" Q
.Q:$$QUIT
.S ITEM=+Y W " ",$E(ITEMS(ITEM),1,33)
.; Quit if doing a Delete and item was selected
.I ITMACT="D" S RMPRQUIT=1 Q
.; Load ICD Code and Code Set and Active Status for selected Item
.D RMPRLOAD
.; If Item doesn't have an ICD code - OK
.I RMPRICD="" W ! S RMPRQUIT=1 Q
.; If Item has an ICD code validate that it was active based on the start
.; date of the prescription. If ICD was active, QUIT
.I RMPRACT="+" S RMPRQUIT=1 Q
.; Otherwise, issue warning
.I ITMACT="E" D
..; Display warning
..D RMPRWARN^RMPOPED1(RMPRICD,RMPRACS,RMPODFN,IEN(ITEM),.RMPRCONT)
..S (RMPRWARN,RMPRQUIT)=1
.W !
K RMPRITEM
Q
;
RMPRLOAD ; Load ICD, Code Set and Status
S RMPRICD=$P(RMPRITEM(ITEM),U,2) ; ICD Code
S RMPRCS=$P(RMPRITEM(ITEM),U,3) ; Code Set
S RMPRACT=$P(RMPRITEM(ITEM),U,4) ; Active Status
Q
;
ITEME ; Edit an Item - ICD-10 Changes
N DFCP,FCP,ICDID,RMCPRENT,RMPRACS,RMPRACSI,RMPRCSI,RMPRDATA,RMPRDATE,RMPRFILE,RMPRICD
N RMPRICDE,RMPRICDI,RMPRIEN,RMPRIENS,RMPRINDX,RMPRQUIT,RMCPTHCP,RMPRTXT,RMPOHCP
S (DFCP,FCP,ICDID,RMCPRENT,RMPRACS,RMPRACSI,RMPRCSI,RMPRDATA,RMPRDATE,RMPRICD,RMPRICDE)=""
S (RMPRICDI,RMPRIEN,RMPRIENS,RMPRQUIT,RMCPTHCP,RMPRTXT)=""
S ITMACT=$G(ITMACT)
K DIE,DA,DR,RMCPT,RMPOHCP
S DA(1)=RMPODFN,DA=IEN(ITEM),DIE="^RMPR(665,"_DA(1)_",""RMPOC"","
D ITEMEP Q:QUIT
S DR=".01R;6R" D ^DIE Q:$$EQUIT!('$D(DA))
ITEMEH ;CHECK HCPCS code for inactive ;RMPR*3.0*180
S RMPOHCP=$P(^RMPR(665,DA(1),"RMPOC",DA,0),U,7)
I RMPOHCP,$P(^RMPR(661.1,RMPOHCP,0),U,5)=0 D G ITEMEH
. W !!,"Inactivated HCPCS not allowed, please enter active code",!!
. S DR="6R" D ^DIE
;
S RMCPTHCP=$P($G(^RMPR(665,RMPODFN,"RMPOC",DA,0)),U,7) ; (#6) HCPCS CODE
S RMCPT=$P($G(^RMPR(661.1,RMCPTHCP,4)),U,1) S DR="" ; (#.03) CPT MODIFIER
S RMCPRENT=$P($G(^RMPR(661.1,RMCPTHCP,5)),U,1) ; (#30) RENTAL FLAG
I RMCPT["RR",(RMCPRENT=1) S DR="11;" ; (#11) HOME OXYGEN RENTAL FLAG
I RMCPT["QH" S DR=DR_"12;" ; (#12) HOME OXYGEN CONSERVING FLAG
;
; Determine Active Coding System based on Date of Interest
S RMPRACS=$$SINFO^ICDEX("DIAG",RMPRDOI) ; Supported by ICR 5747
S RMPRACSI=$P(RMPRACS,U,1)
; Retrieve current ICD code info
S RMPRFILE=665.194,RMPRIENS=IEN(ITEM)_","_RMPODFN_","
S RMPRICDE=$$GET1^DIQ(RMPRFILE,RMPRIENS,7,"E",,) ; External ICD value for use with default value
S RMPRICDI=$$GET1^DIQ(RMPRFILE,RMPRIENS,7,"I",,) ; Internal ICD value
S RMPRIEN=RMPRICDI ; Save IEN in case user accepted default ICD value
I RMPRICDI>0 D
.S RMPRCSI=$$CSI^ICDEX(80,RMPRICDI) ; Code System Internal
.S RMPRDATE=$$SINFO^ICDEX(RMPRCSI)
.S RMPRDATE=$P(RMPRDATE,U,5) ; Implementation date of Code
.; Retrieve ICD info - 20 piece string
.S RMPRDATA=$$ICDDX^ICDEX(RMPRICDE,RMPRDATE,RMPRACSI,"E") ; Supported by ICR 5747
; Prompt for (#1) VENDOR (#2) QUANTITY (#3) UNIT COST (4) UNIT OF ISSUE
S DR=DR_"1R;2R;3R;4"
K RMCPRENT,RMCPTHCP
D ^DIE
Q:$$EQUIT
;
; ICD-9 Code Set
I $P(RMPRACS,U,2)="ICD-9-CM" D
.; Prompt for ICD code
.K DIC
.S DR="7ICD-9 DIAGNOSIS CODE: "
.I RMPRICDE'="" S DIC("B")=RMPRICDE
.D ^DIE
.Q:$$EQUIT
Q:$$QUIT
;
; ICD10 Code Set
I $P(RMPRACS,U,2)="ICD-10-CM" D
.N RMPPARAM
.; Initialize default prompt and help variables
.D SETPARAM^RMPOICD1(.RMPPARAM)
.; If existing ICD-10 code add to default prompt then Prompt and set needed variables
.I +RMPRICDI>0 D
..; If existing ICD-10, add code & description
..S RMPRTXT=$$VLT^ICDEX(80,RMPRICDI,RMPRDOI) ; Supported by ICR 5747
..S RMPPARAM("SEARCH_PROMPT")=RMPPARAM("SEARCH_PROMPT")_RMPRICDE
..S RMPRLLEN=244-$L(RMPPARAM("SEARCH_PROMPT"))
..S RMPPARAM("SEARCH_PROMPT")=RMPPARAM("SEARCH_PROMPT")_" "_$E(RMPRTXT,1,RMPRLLEN)_" "
.; Loop to prompt for ICD-10 code
.F D Q:RMPRQUIT!(+RMPRICD>0) ; user quits OR ICD10 code was selected
..; Output from $$DIAG10^RMPOICD1 = IEN file #80;ICD code value;IEN file # 757.01^description
..S RMPRICD=$$DIAG10^RMPOICD1(RMPRDOI,RMPRICDE,.RMPPARAM)
..; User selected valid code
..I +RMPRICD>0 S RMPRQUIT=1 Q
.. ;if no data found
..I RMPRICD="" W !!,RMPPARAM("NO DATA FOUND") Q
..; User entered ^ OR ^^ to Quit
..I +RMPRICD=-3 S (RMPRQUIT,QUIT)=1 Q
..; User entered <enter> with no existing entry
..I +RMPRICD=-1 S:$P(RMPRICD,U,2)=-1 RMPRQUIT=1 Q
..; Existing ICD and user just pressed <enter>
..I +RMPRICD=-5 S RMPRQUIT=1 Q
..; Check for Deleting the ICD from the item - User entered @
..I +RMPRICD=-6 D Q
...I RMPRICDE="" W " <NOTHING TO DELETE>" Q
...I $$QUESTION^RMPOICD1(1,RMPPARAM("DELETE IT"))=1 D DLTITEM^RMPOPED1(RMPODFN,IEN(ITEM)) S RMPRQUIT=1 Q
...W " <NOTHING DELETED>",!
..; User timed out = QUIT
..I +RMPRICD=-2 S (RMPRQUIT,QUIT)=1 Q
..; User answered No to the "Do you wish to continue" prompt
..I +RMPRICD=-4 Q
.;
.Q:$$QUIT
.; Set ICD Code (#7)
.I +RMPRICD>0 D
..S DR="7////"_+RMPRICD
..D ^DIE
;
Q:$$QUIT
; The final two fields are ask regardless of whether it was an ICD-9 or ICD-10 code
S DR="8;9R" ; (#8) REMARKS (#9) ITEM TYPE
D ^DIE
I $D(DA),$D(RMCPT),(RMCPT'["RR") S $P(^RMPR(665,DA(1),"RMPOC",DA,0),U,12)="" ; (#11) HOME OXYGEN RENTAL FLAG
I $D(DA),$D(RMCPT),(RMCPT'["QH") S $P(^RMPR(665,DA(1),"RMPOC",DA,0),U,13)="" ; (#12) HOME OXYGEN CONSERVING FLAG
Q:$$EQUIT
; Kludge to "point" to file 420
S DFCP=$P(^RMPR(665,RMPODFN,"RMPOC",IEN(ITEM),0),U,6) ;(#5) FUND CONTROL POINT
F D Q:(FCP>0)!QUIT
. S FCP=$$GETFCP^RMPOBILU(DFCP) Q:QUIT
. I FCP<0 W $C(7)_"REQUIRED FIELD!"
I FCP>0 S DR="5///"_$P(FCP,U,2) D ^DIE Q:$$EQUIT
; End Kludge
;S DR="7:9" D ^DIE Q:$$EQUIT
Q
;
ITEMEP ; Primary Item edit...
N PIEN,PFLG,RMDA,RMNO
S RMDA=DA,DR="10" D ^DIE Q:$$QUIT
I $P(^RMPR(665,RMPODFN,"RMPOC",RMDA,0),U,11)'="Y" Q
; Logic to control toggling of Primary Item flag...
S RMNO="N"
F RMX=0:0 S RMX=$O(^RMPR(665,RMPODFN,"RMPOC",RMX)) Q:RMX'>0 D
. Q:RMDA=RMX
. S DA=RMX,DR="10///^S X=RMNO" D ^DIE
S DA=RMDA
Q
PIEN(DFN) ; FIND PRIMARY ITEM
; RETURN IEN OF P.I. IN MULTIPLE ^ IEN IN FILE 661
N X,PIEN
S X=0,PIEN=0
F S X=$O(^RMPR(665,DFN,"RMPOC",X)) Q:X'>0 D Q:PIEN
. S:$P(^RMPR(665,DFN,"RMPOC",X,0),U,11)="Y" PIEN=X
S:PIEN PIEN=PIEN_U_$P(^RMPR(665,DFN,"RMPOC",PIEN,0),U,1)
Q PIEN
;
ITEMD ; Display Items
N I,Z,PIF,ITMNM,VDRNM,RMPRACS,RMPRACT,RMPRICD,RMPRPCS,RMPRTXT
S (RMPRACS,RMPRICD,RMPRPCS)=""
; Determine Active Coding System based on Prescription DOI
S RMPRPCS=$$SINFO^ICDEX("DIAG",RMPRDOI)
K IEN,ITEMS,RMPRITEM S I=0
Q:$O(^RMPR(665,RMPODFN,"RMPOC",0))'>0
W !!,"The following items are already in this patient's template:",!
W !," Item Description Vendor ICD CS+"
F IEN=1:1 S I=$O(^RMPR(665,RMPODFN,"RMPOC",I)) Q:I'>0 D
. S Z=^RMPR(665,RMPODFN,"RMPOC",I,0)
. S PIF=$S($P(Z,U,11)="Y":"*",1:" ")
. ; Load ICD and determine corresponding code set
. S RMPRICD=$P(Z,U,8),RMPRACT=""
. I RMPRICD'="" D
. . ; Check whether ICD code for this item was active on DOI
. . S RMPRACT=$$LS^ICDEX(80,+RMPRICD,RMPRDOI,1)
. . ; Get Active Coding System Info
. . S RMPRACS=$$CSI^ICDEX(80,+RMPRICD) ; Get interal coding system for this ICD code
. . S RMPRACS=$$SINFO^ICDEX(RMPRACS) ; get external format for coding system
. . S RMPRACS=$P(RMPRACS,U,2),RMPRACS=$P(RMPRACS,"-",2)
. . S RMPRICD=$$CODEC^ICDEX(80,RMPRICD)
. S ITMNM=$$ITEMNM($P(Z,U)),VDRNM=$$VDRNM($P(Z,U,2))
. S IEN(IEN)=I
. S VDRNM=$E(VDRNM,1,23)
. S RMPRTXT=PIF_$J(IEN,3)_" "_$$LJ(ITMNM,38)_$$LJ(VDRNM,24)
. S RMPRITEM(IEN)=RMPRTXT
. I RMPRICD'="" D
. . S $E(RMPRTXT,69)="",RMPRTXT=RMPRTXT_RMPRICD
. . S $E(RMPRTXT,78)=""
. . I RMPRACS=9 S RMPRTXT=RMPRTXT_" "
. . S RMPRTXT=RMPRTXT_RMPRACS
. . I +RMPRACT=1 S RMPRTXT=RMPRTXT_"+"
. W !,RMPRTXT
. S ITEMS(IEN)=RMPRTXT
. S $P(RMPRITEM(IEN),U,2)=RMPRICD,$P(RMPRITEM(IEN),U,3)=RMPRACS,$P(RMPRITEM(IEN),U,4)=$S(+RMPRACT=1:"+",1:"")
W !!," * = Primary Item "
W !,"CS = Code Set for ICD Diagnosis code"
W !," + = Item with active ICD code on start date of prescription",!
S IEN=IEN-1
Q
;
ITEMNM(ITM) ; RETURN ITEM NAME
S IENS=ITM_","
D GETS^DIQ(661,IENS,.01,"","X")
Q $E(X(661,IENS,.01),1,33)
VDRNM(VDR) ; RETURN VENDOR NAME
I VDR="" Q "<< VENDOR NOT DEFINED >>"
S IENS=VDR_"," D GETS^DIQ(440,IENS,.01,"","X")
Q X(440,IENS,.01)
ITEMK ; Delete an Item
;
K DIR S DIR(0)="Y",DIR("A")="Are you SURE you want to delete this item"
S DIR("B")="NO" D ^DIR Q:Y'>0
K DIK,DA
S DA(1)=RMPODFN,DA=IEN(ITEM),DIK="^RMPR(665,"_DA(1)_",""RMPOC"","
D ^DIK W " ...deleted!"
Q
ITEMO() ; Choose Option
K DIR
S DIR(0)="SBO^A:Add;D:Delete;E:Edit",DIR("A")="Select ACTION" D ^DIR
Q Y
;
PARSE(RMPRTXT) ; Utility to break line of text over 80 characters into 2 lines
; Input:
; RMPRTXT = Two line array to parse
; RMPRTXT(1) = ICD-## Diagnosis code: ###.#### - Required
; RMPRTXT(2) = Full Description up to 245 characters Required
; RMPRTXT(3) = Suspense Info Optional
;
; Output:
; RMPRTXT array with each line of text < 80 characters and ending in a whole word.
;
;
N RMPRFND,RMPRCNT1,RMPRCNT2,RMPRLLEN,RMPRSUSP
S RMPRFND=""
I $G(RMPRTXT(1))="" S RMPRTXT(1)="No ICD Code" Q
I $G(RMPRTXT(2))="" S RMPRTXT(2)="No ICD Code Description" Q
; Save Suspense Data if it exists
S RMPRSUSP=$G(RMPRTXT(3)) K RMPRTXT(3)
; Check to see if Code & Description will fit on one 80 character line
I $L(RMPRTXT(1))+$L(RMPRTXT(2))'>80 D Q
.S RMPRTXT(1)=RMPRTXT(1)_RMPRTXT(2)
.K RMPRTXT(2)
.; If Suspense info, add it to end of description
.I $L(RMPRSUSP)>0 D Q
..I $L(RMPRTXT(1))<47 S RMPRTXT(1)=RMPRTXT(1)_RMPRSUSP Q
..S RMPRTXT(2)=RMPRSUSP
..Q
; Adjust parser for 1st line with ICD Code plus 1 space after ICD code
S RMPRLLEN=80-$L(RMPRTXT(1))+1
F RMPRCNT1=RMPRLLEN:-1:1 D Q:RMPRFND
.I $E(RMPRTXT(2),RMPRCNT1)=" " D Q:RMPRFND
..S RMPRTXT(1)=RMPRTXT(1)_$E(RMPRTXT(2),1,RMPRCNT1-1)
..S RMPRTXT(2)=" "_$E(RMPRTXT(2),RMPRCNT1+1,999)
..S RMPRFND=1
; Loop through remainder of Description text and parse into 80 character lines with no word breaks
F RMPRCNT1=2:1 Q:'$D(RMPRTXT(RMPRCNT1))!($L(RMPRTXT(RMPRCNT1))'>80) D ; Line counter
.S RMPRFND=0
.F RMPRCNT2=80:-1:1 D Q:RMPRFND ; line break counter
..I $E(RMPRTXT(RMPRCNT1),RMPRCNT2)=" " D Q:RMPRFND
...S RMPRTXT(RMPRCNT1+1)=" "_$E(RMPRTXT(RMPRCNT1),RMPRCNT2+1,999)
...S RMPRTXT(RMPRCNT1)=$E(RMPRTXT(RMPRCNT1),1,RMPRCNT2-1)
...S RMPRFND=1 ; Stop for line breaks
; If Suspense info, add it to end of description
I $L(RMPRSUSP)>0 D
.; Check to Add to last line
.I $L(RMPRTXT(RMPRCNT1))<47 S RMPRTXT(RMPRCNT1)=RMPRTXT(RMPRCNT1)_" "_RMPRSUSP Q
.; Add to new line
.I $L(RMPRTXT(RMPRCNT1))'<47 S RMPRTXT(RMPRCNT1+1)=" "_RMPRSUSP
Q
; End of RMPOPED
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOPED 19841 printed Sep 23, 2025@20:07:25 Page 2
RMPOPED ;EDS/MDB,DDW,RVD - HOME OXYGEN MISC FILE EDITS ;7/24/98
+1 ;;3.0;PROSTHETICS;**29,44,41,52,77,110,140,148,168,180,207**;Feb 09, 1996;Build 15
+2 ;
+3 ; Reference to $$SINFO^ICDEX supported by ICR #5747
+4 ; Reference to $$CSI^ICDEX supported by ICR #5747
+5 ; Reference to $$ICDDX^ICDEX supported by ICR #5747
+6 ; Reference to $$VLT^ICDEX supported by ICR #5747
+7 ; Reference to $$CODEC^ICDEX supported by ICR #5747
+8 ; Reference to $$LS^ICDEX supported by ICR #5747
+9 ;
+10 ; HNC - patch 52
+11 ; modified SITECHK sub
+12 ; X will be undefined from GETS^DIQ if field is null
+13 ; added $G.
+14 ; RVD - patch #77 use FileMan to set items that are not Primary item
+15 ; to 'N' in order to set correctly the 'AC' cross-ref.
+16 ;
+17 ; RGB - PATCH 180 When HCPCS code displays inactive message the user
+18 ; will now be required to use an active code
+19 ;
+20 ; RGB - PATCH 207 Allow expiration date to print with script dates
+21 QUIT
UNLOCK IF $DATA(RMPODFN)
LOCK -^RMPR(665,RMPODFN)
+1 QUIT
EXIT KILL DIC,DIE,DIR,DIK,X,Y,Z,DR,DA,DD,DO,D0,DTOUT,DIROUT,DUOUT,DIRUT,QUIT,DFN,ITEM,ITEMS,IEN,IENS,ITMACT,ITM,C,S,W,PI,VDR,ZST
+1 DO UNLOCK
+2 QUIT
+3 ;
KEY ;user must have the RMPRSUPERVISOR key in order to add a new patient.
+1 ;option name is EDIT HOME OXYGEN PATIENT
+2 NEW KEY
+3 SET KEY=$ORDER(^DIC(19.1,"B","RMPRSUPERVISOR",0))
+4 IF '$DATA(^VA(200,DUZ,51,KEY))
Begin DoDot:1
+5 WRITE !!,"You do not hold the RMPRSUPERVISOR key!!"
End DoDot:1
QUIT
+6 GOTO PAT
+7 ;
SITE ; Editing of Home Oxygen site parameter file.
+1 KILL DIC,DIE,DA,DR,DD,RMPOXITE
+2 SET DIC="^RMPR(669.9,"
SET DIC(0)="QEAMLZ"
SET DIC("A")="Select SITE: "
+3 DO ^DIC
if Y<0!$$QUIT
QUIT
+4 KILL DIC("A")
+5 SET (DA,RMPOXITE)=+Y
+6 ; Lock it...
+7 LOCK +^RMPR(669.9,RMPOXITE):2
+8 IF '$TEST
Begin DoDot:1
+9 WRITE ?10,$CHAR(7)_Y(0,0)_" -- record in use. Try again later."
End DoDot:1
GOTO SITE
+10 ; Edit it
+11 SET DIE=DIC
SET DR="60;61;62;65"
DO ^DIE
if $$EQUIT
QUIT
+12 ; Edit FCP
+13 KILL DIC,DA,DD,DR,DIE
+14 ;
+15 ; Done. Unlock
+16 LOCK -^RMPR(669.9,RMPOXITE)
+17 GOTO SITE
+18 ;
FCPHLP ; Executable help for FCP multiple in 669.9
+1 ;
+2 QUIT
FCPIX ; Input transform for FCP multiple in 669.9
+1 ;
+2 if '$DATA(X)
QUIT
+3 IF $LENGTH(X)>30!($LENGTH(X)<3)
KILL X
QUIT
+4 SET ZST=$PIECE(^RMPR(669.9,D0,4),U,1)
SET RMPOX=X
+5 DO FIND^DIC(420.01,","_ZST_",",".01;","M",X,1,,,,"X")
+6 SET X=$SELECT($DATA(X("DILIST","ID",1,.01)):X("DILIST","ID",1,.01),1:RMPOX)
+7 KILL X("DILIST"),RMPOX
+8 IF $GET(ZST)
IF ('$DATA(^PRC(420,+ZST,1,"B",X)))
WRITE !,"Control Point is not a valid IFCAP FCP.."
KILL X
+9 QUIT
ACT ;activate/inactivate a home oxygen patient
+1 ;Set up site variables.
+2 DO HOSITE^RMPOUTL0
IF QUIT
DO EXIT
QUIT
+3 WRITE @IOF
+4 ;
ACT1 ;Toggle ACTIVATE/INACTIVATE functions.
+1 NEW NAME
KILL DIC,DA
+2 SET DIC="^RMPR(665,"
SET DIC(0)="QEAMZ"
DO ^DIC
IF Y<0!$$QUIT
DO EXIT
QUIT
+3 SET DIE=DIC
SET DA=+Y
SET NAME=Y(0,0)
+4 LOCK +^RMPR(665,DA):2
+5 IF '$TEST
Begin DoDot:1
+6 WRITE ?10,$CHAR(7)_Y(0,0)_" -- record in use. Try later."
End DoDot:1
GOTO ACT1
+7 ;If the patient has never been activated, quit.
+8 IF $PIECE($GET(^RMPR(665,DA,"RMPOA")),U,2)=""
Begin DoDot:1
+9 WRITE !!,$CHAR(7)_NAME_" has not been added as a Home Oxygen patient."
+10 WRITE !,"Please add using the ""Add/Edit Home Oxygen Patient"" option."
End DoDot:1
GOTO ACT1
+11 ;If the patient is active, perform inactivation actions.
+12 IF $PIECE($GET(^RMPR(665,DA,"RMPOA")),U,3)=""
DO INACTVT^RMPOPED
GOTO ACT1
+13 ;If the patient is inactive, perform activation actions.
+14 IF $PIECE($GET(^RMPR(665,DA,"RMPOA")),U,3)'=""
DO ACTVT^RMPOPED
GOTO ACT1
+15 QUIT
INACTVT ; Inactivate the patient if user wants to.
+1 ; Confirm if the user wants to proceed.
+2 KILL DIR
SET DIR(0)="YO"
SET DIR("B")="NO"
+3 SET DIR("A")="Are you sure you want to inactivate "_NAME_" ?"
DO ^DIR
+4 if (Y<1)!$$QUIT
QUIT
+5 SET DR="19.5//TODAY;19.6;19.7////"_DUZ
SET DIE("NO^")="BACK"
+6 DO ^DIE
+7 QUIT
+8 ;
ACTVT ;Activate the patient if the user wants to.
+1 KILL DIR
SET DIR(0)="YO"
SET DIR("B")="NO"
+2 SET DIR("A")="Are you sure you want to reactivate "_NAME_" ?"
DO ^DIR
+3 if (Y<1)!$$QUIT
QUIT
+4 SET DR="19.2//TODAY;19.5///@;19.6///@;19.7///@"
+5 SET DIE("NO^")="BACK"
+6 DO ^DIE
+7 QUIT
PAT ;Add/Edit Home Oxygen Patient
+1 SET QUIT=0
+2 DO HOSITE^RMPOUTL0
+3 IF '$DATA(RMPOXITE)!QUIT
DO EXIT
QUIT
LOOP ;
+1 SET QUIT=0
+2 DO LOOKUP
IF QUIT!'$DATA(RMPODFN)
DO EXIT
QUIT
+3 DO EDBLK
IF QUIT
DO EXIT
QUIT
+4 DO UNLOCK
GOTO LOOP
EDBLK ;
+1 DO SITECHK
if QUIT
QUIT
+2 ; ICD - Date of Interest
NEW RMPRDOI
+3 ; Flag if Prescription/Item mismatch was issued
NEW RMPRWARN
+4 ; Flag if user wanted to continue after warning was issued
NEW RMPRCONT
+5 SET (RMPRWARN,RMPRCONT,RMPRDOI)=""
+6 DO DEMOG
if QUIT
QUIT
+7 DO RX
if QUIT
QUIT
+8 if +RMPRDOI'>0
QUIT
+9 DO ITEM
+10 QUIT
+11 ;called by ^RMPOBIL1, providing RMPOPATN as the X variable
EDIT ;From Billing...
+1 IF '$DATA(RMPODFN)
SET RMPODFN=$TRANSLATE($GET(RMPOPATN),"`")
+2 if '$DATA(^RMPR(665,+RMPODFN,0))
QUIT
+3 WRITE !,"EDITING "_$PIECE(^DPT(RMPODFN,0),U)_"...",!
+4 SET QUIT=0
SET DA=RMPODFN
+5 LOCK +^RMPR(665,DA):2
+6 IF '$TEST
WRITE !!?10,*7," << Record in use. Try later. >>"
QUIT
+7 DO EDBLK
DO EXIT
+8 QUIT
LOOKUP ;First look-up the patient
+1 KILL DIC,DIE,DA,DR,RMPODFN
+2 WRITE !!!
SET DIC="^RMPR(665,"
SET DIC(0)="LQEAMZ"
+3 DO ^DIC
if (Y<0)!$$QUIT
QUIT
CONT SET (RMPODFN,DA)=+Y
+1 LOCK +^RMPR(665,DA):2
+2 IF '$TEST
WRITE !!?10,*7," << Record in use. Try later. >>"
GOTO LOOKUP
+3 QUIT
+4 ;
QUIT() SET QUIT=$GET(QUIT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT QUIT
EQUIT() SET QUIT=$DATA(DTOUT)!$DATA(Y)
QUIT QUIT
LJ(S,W,C) ; LEFT JUSTIFY S IN A FIELD W WIDE PADDING WITH CHAR F
+1 ;
+2 ;DEFAULT PAD CHAR IS SPACE
SET C=$GET(C," ")
+3 SET $PIECE(S,C,W-$LENGTH(S)+$LENGTH(S,C))=""
+4 QUIT S
+5 ;
SITECHK ;If user chooses patient from site different from billing site
+1 ;
+2 SET Y=$PIECE($GET(^RMPR(665,RMPODFN,"RMPOA")),U,7)
+3 ;Site is the same..
if Y=RMPOXITE
QUIT
+4 ;Site not defined, stuff RMPOXITE...
IF Y=""
DO SET
QUIT
+5 ; Site is different...
+6 SET IENS=RMPODFN_","
+7 DO GETS^DIQ(665,IENS,19.12,"E","X")
+8 WRITE !!,"Patient's Home Oxygen Contract Location (HOCL) is "
+9 WRITE $GET(X(665,IENS,19.12,"E"))
+10 WRITE !,"You are working on billing for HOCL "_RMPO("NAME"),!
+11 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="NO"
+12 SET DIR("A")="Should I change this patient's HOCL to "_RMPO("NAME")
+13 DO ^DIR
if $$QUIT!(Y=0)
QUIT
+14 DO SET
+15 QUIT
SET ;
+1 KILL DIE,DR,DA
+2 SET DA=RMPODFN
+3 SET DIE="^RMPR(665,"
SET DR="19.12////"_RMPOXITE
DO ^DIE
+4 QUIT
+5 ;
DEMOG ;First edit the patient's basic fields
+1 ;
+2 KILL DIE,DR,DA
+3 SET DA=RMPODFN
+4 SET DIE="^RMPR(665,"
SET DR="19.1"
DO ^DIE
if $$EQUIT
QUIT
+5 SET RMPOELIG=$PIECE($GET(^RMPR(665,RMPODFN,"RMPOA")),U)
+6 KILL DR
SET DR="19.11"_$SELECT(RMPOELIG="D":"",1:"///@")_";19.12"
+7 DO ^DIE
if $$EQUIT
QUIT
+8 KILL DR
SET Y=DT
XECUTE ^DD("DD")
SET DR="19.2//"_Y
DO ^DIE
if $$QUIT
QUIT
+9 QUIT
+10 ;
RX ;Edit the Rx Data
+1 ;
+2 NEW RXD,RXDI,RMPRIENS
+3 KILL DIC,DIE,DA,DR
+4 SET DIC("W")="N C,DINAME W "" "" W "" "",$$NAKED^DIUTL(""$$DATE^DIUTL($P(^(0),U,3))"")"
+5 SET DIC="^RMPR(665,"_RMPODFN_",""RMPOB"","
SET DIC(0)="AEQLZ"
+6 SET DA(1)=RMPODFN
SET DIC("P")="665.193D"
+7 SET RXD=$ORDER(^RMPR(665,DA(1),"RMPOB","B",""),-1)
if RXD
Begin DoDot:1
+8 SET DIC("B")=$$FMTE^XLFDT(RXD)
End DoDot:1
+9 DO ^DIC
if Y<0!$$QUIT
QUIT
+10 ; Set RMPRIENS for loading Date of Interest after final edits
+11 SET RMPRIENS=+Y_","_DA(1)_","
+12 ; Edit START DATE (#.01), EXPIRATION DATE (#2) and DESCRIPTION (#3)
+13 SET DIE=DIC
SET DA=+Y
SET DR=".01;2//^D EXPIRE^RMPOBIL4;3"
DO ^DIE
if $$EQUIT
QUIT
+14 ; Load ICD Date of Interest
+15 SET RMPRDOI=$$GET1^DIQ(665.193,RMPRIENS,.01,"I",,)
+16 QUIT
+17 ;
ITEM ;Add/Edit Items
+1 ;
+2 ; Display items
+3 DO ITEMD
+4 ; If no items on file, then only allow ADD PRIMARY ITEM
+5 IF '$DATA(IEN)
DO ITEMP
if QUIT!(ITEM="")
QUIT
GOTO ITEM
+6 ; ask for ACTION, quit if <return>, timeout, etc
+7 SET ITMACT=$$ITEMO
if $$QUIT!(ITMACT="")
QUIT
+8 ; if they entered 'A', do ADD ITEM, then edit it
+9 IF ITMACT="A"
DO ITEMA
if QUIT!(ITEM="")
QUIT
DO ITEME
if QUIT
QUIT
GOTO ITEM
+10 ; if they entered 'D', select an item, then delete it
+11 IF ITMACT="D"
DO ITEMS
if QUIT!(ITEM="")
QUIT
DO ITEMK
GOTO ITEM
+12 ; if they entered 'E', select an item, then edit it
+13 IF ITMACT="E"
DO ITEMS
+14 ; If warning issued and Continue = No
+15 IF RMPRWARN=1
IF RMPRCONT'=1
SET (RMPRWARN,RMPRCONT)=""
GOTO ITEM
+16 if QUIT!(ITEM="")
QUIT
+17 DO ITEME
if QUIT
QUIT
+18 GOTO ITEM
+19 QUIT
+20 ;
ITEMP ; Add Primary Item
+1 WRITE !!,$CHAR(7)_"No items found, please enter PRIMARY ITEM",!
+2 DO ITEMA
if QUIT!(ITEM="")
QUIT
+3 SET PI="///Y"
DO ITEME
KILL PI
+4 QUIT
ITEMA ; Add Items
+1 SET ITEM=""
+2 KILL DIC
SET DIC="^RMPR(661,"
SET DIC(0)="AEQMZ"
DO ^DIC
if Y<0!$$QUIT
QUIT
+3 KILL DD,DO,DA,DIC
+4 SET DIC="^RMPR(665,"_RMPODFN_",""RMPOC"","
SET DIC(0)="L"
+5 SET DIC("P")=$PIECE(^DD(665,19.4,0),U,2)
SET DA(1)=RMPODFN
SET X=+Y
+6 DO FILE^DICN
IF Y>0
SET IEN=$GET(IEN)+1
SET IEN(IEN)=+Y
SET ITEM=IEN
+7 QUIT
+8 ;
ITEMS ; Select Item
+1 ; Return ITEM = index into both ITEMS and IEN arrays
+2 NEW RMPRQUIT,RMPRACS,RMPRCS,RMPRICD,RMPRICS,RMPRANS,RMPRACT
+3 ; Determine Active Coding System based on Date of Interest
+4 ; Supported by ICR 5747
SET RMPRACS=$$SINFO^ICDEX("DIAG",RMPRDOI)
+5 SET RMPRACS=$PIECE(RMPRACS,U,2)
SET RMPRACS=$PIECE(RMPRACS,"-",2)
+6 ; If only one Item on file
+7 IF IEN=1
SET ITEM=1
WRITE " ",$EXTRACT(ITEMS(1),1,33)
if ITMACT'="E"
QUIT
Begin DoDot:1
+8 ; Load Item info
+9 DO RMPRLOAD
+10 ; If item has an ICD code, verify that it was active based on
+11 ; start date of currently selected prescription.
+12 IF RMPRICD'=""
IF RMPRACT'="+"
Begin DoDot:2
+13 ; Display warning
+14 DO RMPRWARN^RMPOPED1(RMPRICD,RMPRACS,RMPODFN,.ITEM,.RMPRCONT)
+15 ; Set warning issued flag
SET RMPRWARN=1
End DoDot:2
End DoDot:1
QUIT
+16 ; If multiple items on file
+17 KILL DIR
+18 SET ITEM=""
+19 SET DIR(0)="NO^1:"_IEN
SET DIR("A")="Select an ITEM"
+20 SET DIR("?")="Select an item from the list"
+21 MERGE DIR("?")=ITEMS
+22 FOR
Begin DoDot:1
+23 SET RMPRQUIT=""
+24 DO ^DIR
+25 IF Y'>0
SET RMPRQUIT=1
SET ITEM=""
QUIT
+26 if $$QUIT
QUIT
+27 SET ITEM=+Y
WRITE " ",$EXTRACT(ITEMS(ITEM),1,33)
+28 ; Quit if doing a Delete and item was selected
+29 IF ITMACT="D"
SET RMPRQUIT=1
QUIT
+30 ; Load ICD Code and Code Set and Active Status for selected Item
+31 DO RMPRLOAD
+32 ; If Item doesn't have an ICD code - OK
+33 IF RMPRICD=""
WRITE !
SET RMPRQUIT=1
QUIT
+34 ; If Item has an ICD code validate that it was active based on the start
+35 ; date of the prescription. If ICD was active, QUIT
+36 IF RMPRACT="+"
SET RMPRQUIT=1
QUIT
+37 ; Otherwise, issue warning
+38 IF ITMACT="E"
Begin DoDot:2
+39 ; Display warning
+40 DO RMPRWARN^RMPOPED1(RMPRICD,RMPRACS,RMPODFN,IEN(ITEM),.RMPRCONT)
+41 SET (RMPRWARN,RMPRQUIT)=1
End DoDot:2
+42 WRITE !
End DoDot:1
if RMPRQUIT=1
QUIT
+43 KILL RMPRITEM
+44 QUIT
+45 ;
RMPRLOAD ; Load ICD, Code Set and Status
+1 ; ICD Code
SET RMPRICD=$PIECE(RMPRITEM(ITEM),U,2)
+2 ; Code Set
SET RMPRCS=$PIECE(RMPRITEM(ITEM),U,3)
+3 ; Active Status
SET RMPRACT=$PIECE(RMPRITEM(ITEM),U,4)
+4 QUIT
+5 ;
ITEME ; Edit an Item - ICD-10 Changes
+1 NEW DFCP,FCP,ICDID,RMCPRENT,RMPRACS,RMPRACSI,RMPRCSI,RMPRDATA,RMPRDATE,RMPRFILE,RMPRICD
+2 NEW RMPRICDE,RMPRICDI,RMPRIEN,RMPRIENS,RMPRINDX,RMPRQUIT,RMCPTHCP,RMPRTXT,RMPOHCP
+3 SET (DFCP,FCP,ICDID,RMCPRENT,RMPRACS,RMPRACSI,RMPRCSI,RMPRDATA,RMPRDATE,RMPRICD,RMPRICDE)=""
+4 SET (RMPRICDI,RMPRIEN,RMPRIENS,RMPRQUIT,RMCPTHCP,RMPRTXT)=""
+5 SET ITMACT=$GET(ITMACT)
+6 KILL DIE,DA,DR,RMCPT,RMPOHCP
+7 SET DA(1)=RMPODFN
SET DA=IEN(ITEM)
SET DIE="^RMPR(665,"_DA(1)_",""RMPOC"","
+8 DO ITEMEP
if QUIT
QUIT
+9 SET DR=".01R;6R"
DO ^DIE
if $$EQUIT!('$DATA(DA))
QUIT
ITEMEH ;CHECK HCPCS code for inactive ;RMPR*3.0*180
+1 SET RMPOHCP=$PIECE(^RMPR(665,DA(1),"RMPOC",DA,0),U,7)
+2 IF RMPOHCP
IF $PIECE(^RMPR(661.1,RMPOHCP,0),U,5)=0
Begin DoDot:1
+3 WRITE !!,"Inactivated HCPCS not allowed, please enter active code",!!
+4 SET DR="6R"
DO ^DIE
End DoDot:1
GOTO ITEMEH
+5 ;
+6 ; (#6) HCPCS CODE
SET RMCPTHCP=$PIECE($GET(^RMPR(665,RMPODFN,"RMPOC",DA,0)),U,7)
+7 ; (#.03) CPT MODIFIER
SET RMCPT=$PIECE($GET(^RMPR(661.1,RMCPTHCP,4)),U,1)
SET DR=""
+8 ; (#30) RENTAL FLAG
SET RMCPRENT=$PIECE($GET(^RMPR(661.1,RMCPTHCP,5)),U,1)
+9 ; (#11) HOME OXYGEN RENTAL FLAG
IF RMCPT["RR"
IF (RMCPRENT=1)
SET DR="11;"
+10 ; (#12) HOME OXYGEN CONSERVING FLAG
IF RMCPT["QH"
SET DR=DR_"12;"
+11 ;
+12 ; Determine Active Coding System based on Date of Interest
+13 ; Supported by ICR 5747
SET RMPRACS=$$SINFO^ICDEX("DIAG",RMPRDOI)
+14 SET RMPRACSI=$PIECE(RMPRACS,U,1)
+15 ; Retrieve current ICD code info
+16 SET RMPRFILE=665.194
SET RMPRIENS=IEN(ITEM)_","_RMPODFN_","
+17 ; External ICD value for use with default value
SET RMPRICDE=$$GET1^DIQ(RMPRFILE,RMPRIENS,7,"E",,)
+18 ; Internal ICD value
SET RMPRICDI=$$GET1^DIQ(RMPRFILE,RMPRIENS,7,"I",,)
+19 ; Save IEN in case user accepted default ICD value
SET RMPRIEN=RMPRICDI
+20 IF RMPRICDI>0
Begin DoDot:1
+21 ; Code System Internal
SET RMPRCSI=$$CSI^ICDEX(80,RMPRICDI)
+22 SET RMPRDATE=$$SINFO^ICDEX(RMPRCSI)
+23 ; Implementation date of Code
SET RMPRDATE=$PIECE(RMPRDATE,U,5)
+24 ; Retrieve ICD info - 20 piece string
+25 ; Supported by ICR 5747
SET RMPRDATA=$$ICDDX^ICDEX(RMPRICDE,RMPRDATE,RMPRACSI,"E")
End DoDot:1
+26 ; Prompt for (#1) VENDOR (#2) QUANTITY (#3) UNIT COST (4) UNIT OF ISSUE
+27 SET DR=DR_"1R;2R;3R;4"
+28 KILL RMCPRENT,RMCPTHCP
+29 DO ^DIE
+30 if $$EQUIT
QUIT
+31 ;
+32 ; ICD-9 Code Set
+33 IF $PIECE(RMPRACS,U,2)="ICD-9-CM"
Begin DoDot:1
+34 ; Prompt for ICD code
+35 KILL DIC
+36 SET DR="7ICD-9 DIAGNOSIS CODE: "
+37 IF RMPRICDE'=""
SET DIC("B")=RMPRICDE
+38 DO ^DIE
+39 if $$EQUIT
QUIT
End DoDot:1
+40 if $$QUIT
QUIT
+41 ;
+42 ; ICD10 Code Set
+43 IF $PIECE(RMPRACS,U,2)="ICD-10-CM"
Begin DoDot:1
+44 NEW RMPPARAM
+45 ; Initialize default prompt and help variables
+46 DO SETPARAM^RMPOICD1(.RMPPARAM)
+47 ; If existing ICD-10 code add to default prompt then Prompt and set needed variables
+48 IF +RMPRICDI>0
Begin DoDot:2
+49 ; If existing ICD-10, add code & description
+50 ; Supported by ICR 5747
SET RMPRTXT=$$VLT^ICDEX(80,RMPRICDI,RMPRDOI)
+51 SET RMPPARAM("SEARCH_PROMPT")=RMPPARAM("SEARCH_PROMPT")_RMPRICDE
+52 SET RMPRLLEN=244-$LENGTH(RMPPARAM("SEARCH_PROMPT"))
+53 SET RMPPARAM("SEARCH_PROMPT")=RMPPARAM("SEARCH_PROMPT")_" "_$EXTRACT(RMPRTXT,1,RMPRLLEN)_" "
End DoDot:2
+54 ; Loop to prompt for ICD-10 code
+55 ; user quits OR ICD10 code was selected
FOR
Begin DoDot:2
+56 ; Output from $$DIAG10^RMPOICD1 = IEN file #80;ICD code value;IEN file # 757.01^description
+57 SET RMPRICD=$$DIAG10^RMPOICD1(RMPRDOI,RMPRICDE,.RMPPARAM)
+58 ; User selected valid code
+59 IF +RMPRICD>0
SET RMPRQUIT=1
QUIT
+60 ;if no data found
+61 IF RMPRICD=""
WRITE !!,RMPPARAM("NO DATA FOUND")
QUIT
+62 ; User entered ^ OR ^^ to Quit
+63 IF +RMPRICD=-3
SET (RMPRQUIT,QUIT)=1
QUIT
+64 ; User entered <enter> with no existing entry
+65 IF +RMPRICD=-1
if $PIECE(RMPRICD,U,2)=-1
SET RMPRQUIT=1
QUIT
+66 ; Existing ICD and user just pressed <enter>
+67 IF +RMPRICD=-5
SET RMPRQUIT=1
QUIT
+68 ; Check for Deleting the ICD from the item - User entered @
+69 IF +RMPRICD=-6
Begin DoDot:3
+70 IF RMPRICDE=""
WRITE " <NOTHING TO DELETE>"
QUIT
+71 IF $$QUESTION^RMPOICD1(1,RMPPARAM("DELETE IT"))=1
DO DLTITEM^RMPOPED1(RMPODFN,IEN(ITEM))
SET RMPRQUIT=1
QUIT
+72 WRITE " <NOTHING DELETED>",!
End DoDot:3
QUIT
+73 ; User timed out = QUIT
+74 IF +RMPRICD=-2
SET (RMPRQUIT,QUIT)=1
QUIT
+75 ; User answered No to the "Do you wish to continue" prompt
+76 IF +RMPRICD=-4
QUIT
End DoDot:2
if RMPRQUIT!(+RMPRICD>0)
QUIT
+77 ;
+78 if $$QUIT
QUIT
+79 ; Set ICD Code (#7)
+80 IF +RMPRICD>0
Begin DoDot:2
+81 SET DR="7////"_+RMPRICD
+82 DO ^DIE
End DoDot:2
End DoDot:1
+83 ;
+84 if $$QUIT
QUIT
+85 ; The final two fields are ask regardless of whether it was an ICD-9 or ICD-10 code
+86 ; (#8) REMARKS (#9) ITEM TYPE
SET DR="8;9R"
+87 DO ^DIE
+88 ; (#11) HOME OXYGEN RENTAL FLAG
IF $DATA(DA)
IF $DATA(RMCPT)
IF (RMCPT'["RR")
SET $PIECE(^RMPR(665,DA(1),"RMPOC",DA,0),U,12)=""
+89 ; (#12) HOME OXYGEN CONSERVING FLAG
IF $DATA(DA)
IF $DATA(RMCPT)
IF (RMCPT'["QH")
SET $PIECE(^RMPR(665,DA(1),"RMPOC",DA,0),U,13)=""
+90 if $$EQUIT
QUIT
+91 ; Kludge to "point" to file 420
+92 ;(#5) FUND CONTROL POINT
SET DFCP=$PIECE(^RMPR(665,RMPODFN,"RMPOC",IEN(ITEM),0),U,6)
+93 FOR
Begin DoDot:1
+94 SET FCP=$$GETFCP^RMPOBILU(DFCP)
if QUIT
QUIT
+95 IF FCP<0
WRITE $CHAR(7)_"REQUIRED FIELD!"
End DoDot:1
if (FCP>0)!QUIT
QUIT
+96 IF FCP>0
SET DR="5///"_$PIECE(FCP,U,2)
DO ^DIE
if $$EQUIT
QUIT
+97 ; End Kludge
+98 ;S DR="7:9" D ^DIE Q:$$EQUIT
+99 QUIT
+100 ;
ITEMEP ; Primary Item edit...
+1 NEW PIEN,PFLG,RMDA,RMNO
+2 SET RMDA=DA
SET DR="10"
DO ^DIE
if $$QUIT
QUIT
+3 IF $PIECE(^RMPR(665,RMPODFN,"RMPOC",RMDA,0),U,11)'="Y"
QUIT
+4 ; Logic to control toggling of Primary Item flag...
+5 SET RMNO="N"
+6 FOR RMX=0:0
SET RMX=$ORDER(^RMPR(665,RMPODFN,"RMPOC",RMX))
if RMX'>0
QUIT
Begin DoDot:1
+7 if RMDA=RMX
QUIT
+8 SET DA=RMX
SET DR="10///^S X=RMNO"
DO ^DIE
End DoDot:1
+9 SET DA=RMDA
+10 QUIT
PIEN(DFN) ; FIND PRIMARY ITEM
+1 ; RETURN IEN OF P.I. IN MULTIPLE ^ IEN IN FILE 661
+2 NEW X,PIEN
+3 SET X=0
SET PIEN=0
+4 FOR
SET X=$ORDER(^RMPR(665,DFN,"RMPOC",X))
if X'>0
QUIT
Begin DoDot:1
+5 if $PIECE(^RMPR(665,DFN,"RMPOC",X,0),U,11)="Y"
SET PIEN=X
End DoDot:1
if PIEN
QUIT
+6 if PIEN
SET PIEN=PIEN_U_$PIECE(^RMPR(665,DFN,"RMPOC",PIEN,0),U,1)
+7 QUIT PIEN
+8 ;
ITEMD ; Display Items
+1 NEW I,Z,PIF,ITMNM,VDRNM,RMPRACS,RMPRACT,RMPRICD,RMPRPCS,RMPRTXT
+2 SET (RMPRACS,RMPRICD,RMPRPCS)=""
+3 ; Determine Active Coding System based on Prescription DOI
+4 SET RMPRPCS=$$SINFO^ICDEX("DIAG",RMPRDOI)
+5 KILL IEN,ITEMS,RMPRITEM
SET I=0
+6 if $ORDER(^RMPR(665,RMPODFN,"RMPOC",0))'>0
QUIT
+7 WRITE !!,"The following items are already in this patient's template:",!
+8 WRITE !," Item Description Vendor ICD CS+"
+9 FOR IEN=1:1
SET I=$ORDER(^RMPR(665,RMPODFN,"RMPOC",I))
if I'>0
QUIT
Begin DoDot:1
+10 SET Z=^RMPR(665,RMPODFN,"RMPOC",I,0)
+11 SET PIF=$SELECT($PIECE(Z,U,11)="Y":"*",1:" ")
+12 ; Load ICD and determine corresponding code set
+13 SET RMPRICD=$PIECE(Z,U,8)
SET RMPRACT=""
+14 IF RMPRICD'=""
Begin DoDot:2
+15 ; Check whether ICD code for this item was active on DOI
+16 SET RMPRACT=$$LS^ICDEX(80,+RMPRICD,RMPRDOI,1)
+17 ; Get Active Coding System Info
+18 ; Get interal coding system for this ICD code
SET RMPRACS=$$CSI^ICDEX(80,+RMPRICD)
+19 ; get external format for coding system
SET RMPRACS=$$SINFO^ICDEX(RMPRACS)
+20 SET RMPRACS=$PIECE(RMPRACS,U,2)
SET RMPRACS=$PIECE(RMPRACS,"-",2)
+21 SET RMPRICD=$$CODEC^ICDEX(80,RMPRICD)
End DoDot:2
+22 SET ITMNM=$$ITEMNM($PIECE(Z,U))
SET VDRNM=$$VDRNM($PIECE(Z,U,2))
+23 SET IEN(IEN)=I
+24 SET VDRNM=$EXTRACT(VDRNM,1,23)
+25 SET RMPRTXT=PIF_$JUSTIFY(IEN,3)_" "_$$LJ(ITMNM,38)_$$LJ(VDRNM,24)
+26 SET RMPRITEM(IEN)=RMPRTXT
+27 IF RMPRICD'=""
Begin DoDot:2
+28 SET $EXTRACT(RMPRTXT,69)=""
SET RMPRTXT=RMPRTXT_RMPRICD
+29 SET $EXTRACT(RMPRTXT,78)=""
+30 IF RMPRACS=9
SET RMPRTXT=RMPRTXT_" "
+31 SET RMPRTXT=RMPRTXT_RMPRACS
+32 IF +RMPRACT=1
SET RMPRTXT=RMPRTXT_"+"
End DoDot:2
+33 WRITE !,RMPRTXT
+34 SET ITEMS(IEN)=RMPRTXT
+35 SET $PIECE(RMPRITEM(IEN),U,2)=RMPRICD
SET $PIECE(RMPRITEM(IEN),U,3)=RMPRACS
SET $PIECE(RMPRITEM(IEN),U,4)=$SELECT(+RMPRACT=1:"+",1:"")
End DoDot:1
+36 WRITE !!," * = Primary Item "
+37 WRITE !,"CS = Code Set for ICD Diagnosis code"
+38 WRITE !," + = Item with active ICD code on start date of prescription",!
+39 SET IEN=IEN-1
+40 QUIT
+41 ;
ITEMNM(ITM) ; RETURN ITEM NAME
+1 SET IENS=ITM_","
+2 DO GETS^DIQ(661,IENS,.01,"","X")
+3 QUIT $EXTRACT(X(661,IENS,.01),1,33)
VDRNM(VDR) ; RETURN VENDOR NAME
+1 IF VDR=""
QUIT "<< VENDOR NOT DEFINED >>"
+2 SET IENS=VDR_","
DO GETS^DIQ(440,IENS,.01,"","X")
+3 QUIT X(440,IENS,.01)
ITEMK ; Delete an Item
+1 ;
+2 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Are you SURE you want to delete this item"
+3 SET DIR("B")="NO"
DO ^DIR
if Y'>0
QUIT
+4 KILL DIK,DA
+5 SET DA(1)=RMPODFN
SET DA=IEN(ITEM)
SET DIK="^RMPR(665,"_DA(1)_",""RMPOC"","
+6 DO ^DIK
WRITE " ...deleted!"
+7 QUIT
ITEMO() ; Choose Option
+1 KILL DIR
+2 SET DIR(0)="SBO^A:Add;D:Delete;E:Edit"
SET DIR("A")="Select ACTION"
DO ^DIR
+3 QUIT Y
+4 ;
PARSE(RMPRTXT) ; Utility to break line of text over 80 characters into 2 lines
+1 ; Input:
+2 ; RMPRTXT = Two line array to parse
+3 ; RMPRTXT(1) = ICD-## Diagnosis code: ###.#### - Required
+4 ; RMPRTXT(2) = Full Description up to 245 characters Required
+5 ; RMPRTXT(3) = Suspense Info Optional
+6 ;
+7 ; Output:
+8 ; RMPRTXT array with each line of text < 80 characters and ending in a whole word.
+9 ;
+10 ;
+11 NEW RMPRFND,RMPRCNT1,RMPRCNT2,RMPRLLEN,RMPRSUSP
+12 SET RMPRFND=""
+13 IF $GET(RMPRTXT(1))=""
SET RMPRTXT(1)="No ICD Code"
QUIT
+14 IF $GET(RMPRTXT(2))=""
SET RMPRTXT(2)="No ICD Code Description"
QUIT
+15 ; Save Suspense Data if it exists
+16 SET RMPRSUSP=$GET(RMPRTXT(3))
KILL RMPRTXT(3)
+17 ; Check to see if Code & Description will fit on one 80 character line
+18 IF $LENGTH(RMPRTXT(1))+$LENGTH(RMPRTXT(2))'>80
Begin DoDot:1
+19 SET RMPRTXT(1)=RMPRTXT(1)_RMPRTXT(2)
+20 KILL RMPRTXT(2)
+21 ; If Suspense info, add it to end of description
+22 IF $LENGTH(RMPRSUSP)>0
Begin DoDot:2
+23 IF $LENGTH(RMPRTXT(1))<47
SET RMPRTXT(1)=RMPRTXT(1)_RMPRSUSP
QUIT
+24 SET RMPRTXT(2)=RMPRSUSP
+25 QUIT
End DoDot:2
QUIT
End DoDot:1
QUIT
+26 ; Adjust parser for 1st line with ICD Code plus 1 space after ICD code
+27 SET RMPRLLEN=80-$LENGTH(RMPRTXT(1))+1
+28 FOR RMPRCNT1=RMPRLLEN:-1:1
Begin DoDot:1
+29 IF $EXTRACT(RMPRTXT(2),RMPRCNT1)=" "
Begin DoDot:2
+30 SET RMPRTXT(1)=RMPRTXT(1)_$EXTRACT(RMPRTXT(2),1,RMPRCNT1-1)
+31 SET RMPRTXT(2)=" "_$EXTRACT(RMPRTXT(2),RMPRCNT1+1,999)
+32 SET RMPRFND=1
End DoDot:2
if RMPRFND
QUIT
End DoDot:1
if RMPRFND
QUIT
+33 ; Loop through remainder of Description text and parse into 80 character lines with no word breaks
+34 ; Line counter
FOR RMPRCNT1=2:1
if '$DATA(RMPRTXT(RMPRCNT1))!($LENGTH(RMPRTXT(RMPRCNT1))'>80)
QUIT
Begin DoDot:1
+35 SET RMPRFND=0
+36 ; line break counter
FOR RMPRCNT2=80:-1:1
Begin DoDot:2
+37 IF $EXTRACT(RMPRTXT(RMPRCNT1),RMPRCNT2)=" "
Begin DoDot:3
+38 SET RMPRTXT(RMPRCNT1+1)=" "_$EXTRACT(RMPRTXT(RMPRCNT1),RMPRCNT2+1,999)
+39 SET RMPRTXT(RMPRCNT1)=$EXTRACT(RMPRTXT(RMPRCNT1),1,RMPRCNT2-1)
+40 ; Stop for line breaks
SET RMPRFND=1
End DoDot:3
if RMPRFND
QUIT
End DoDot:2
if RMPRFND
QUIT
End DoDot:1
+41 ; If Suspense info, add it to end of description
+42 IF $LENGTH(RMPRSUSP)>0
Begin DoDot:1
+43 ; Check to Add to last line
+44 IF $LENGTH(RMPRTXT(RMPRCNT1))<47
SET RMPRTXT(RMPRCNT1)=RMPRTXT(RMPRCNT1)_" "_RMPRSUSP
QUIT
+45 ; Add to new line
+46 IF $LENGTH(RMPRTXT(RMPRCNT1))'<47
SET RMPRTXT(RMPRCNT1+1)=" "_RMPRSUSP
End DoDot:1
+47 QUIT
+48 ; End of RMPOPED
