source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOPED.m@ 1111

RMPOPED ;EDS/MDB,DDW,RVD - HOME OXYGEN MISC FILE EDITS ;7/24/98

 ;;3.0;PROSTHETICS;**29,44,41,52,77,110**;Feb 09, 1996;Build 10

 ;

 ; 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.

 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 RMPSUPERVISOR 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

 D DEMOG Q:QUIT

 D RX Q:QUIT

 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=$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

 ;W "HERE,RMPOXITE=",RMPOXITE

 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

 ;

 K DIC,DIE,DA,DR

 S DIC="^RMPR(665,"_RMPODFN_",""RMPOB"",",DIC(0)="AEQLZ"

 S DA(1)=RMPODFN,DIC("P")="665.193D"

 I $D(^DISV(DUZ,DIC)) S Y=^(DIC) I $D(@(DIC_(+Y)_",0)")) D

 . S DIC("B")=$P(^(0),U,1)

 D ^DIC Q:Y<0!$$QUIT

 S DIE=DIC,DA=+Y,DR=".01;2//^D EXPIRE^RMPOBIL4;3" D ^DIE Q:$$EQUIT

 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 Q:QUIT!(ITEM="")  D ITEME Q:QUIT  G ITEM

 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

 I IEN=1 S ITEM=1 W "  ",$E(ITEMS(1),1,33) Q

 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

 D ^DIR Q:Y'>0!$$QUIT

 S ITEM=+Y W "  ",$E(ITEMS(ITEM),1,33)

 Q

ITEME ; Edit an Item

 N FCP,DFCP,RMCPTHCP,RMCPRENT K DIE,DA,DR,RMCPT

 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))

 S RMCPTHCP=$P($G(^RMPR(665,RMPODFN,"RMPOC",DA,0)),U,7)

 S RMCPT=$P($G(^RMPR(661.1,RMCPTHCP,4)),U,1) S DR=""

 S RMCPRENT=$P($G(^RMPR(661.1,RMCPTHCP,5)),U,1)

 I RMCPT["RR",(RMCPRENT=1) S DR="11;"

 I RMCPT["QH" S DR=DR_"12;"

 S DR=DR_"1R;2R;3R;4;7;8;9R" K RMCPRENT,RMCPTHCP

 D ^DIE I $D(DA),$D(RMCPT),(RMCPT'["RR") S $P(^RMPR(665,DA(1),"RMPOC",DA,0),U,12)=""

 I $D(DA),$D(RMCPT),(RMCPT'["QH") S $P(^RMPR(665,DA(1),"RMPOC",DA,0),U,13)=""

 Q:$$EQUIT

 ; Kludge to "point" to file 420

 S DFCP=$P(^RMPR(665,RMPODFN,"RMPOC",IEN(ITEM),0),U,6)

 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

 K IEN,ITEMS S I=0

 Q:$O(^RMPR(665,RMPODFN,"RMPOC",0))'>0

 W !!,"The following items are already in this patient's template:",!

 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:" ")

 . S ITMNM=$$ITEMNM($P(Z,U)),VDRNM=$$VDRNM($P(Z,U,2))

 .; K X S IENS=$P(Z,U)_","

 .; D GETS^DIQ(661,IENS,.01,"","X") S ITMNM=$E(X(661,IENS,.01),1,33)

 .; S IENS=$P(Z,U,2)_",",VDRNM="<< VENDOR NOT DEFINED >>"

 .; I IENS'="," D GETS^DIQ(440,IENS,.01,"","X") S VDRNM=X(440,IENS,.01)

 . S IEN(IEN)=I

 . S ITEMS(IEN)=" "_PIF_$J(IEN,4)_"  "_$$LJ(ITMNM,38)_$E(VDRNM,1,30)

 . W !,ITEMS(IEN)

 W !!," * = Primary Item",!

 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

 Q