Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPOPED

RMPOPED.m

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