- 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 Jan 18, 2025@03:32:26 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