- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOPED.m
r613 r623 1 RMPOPED ;EDS/MDB,DDW,RVD - HOME OXYGEN MISC FILE EDITS ;7/24/98 2 ;;3.0;PROSTHETICS;**29,44,41,52,77,110,140,148**;Feb 09, 1996;Build 1 3 ; 4 ; HNC - patch 52 5 ; modified SITECHK sub 6 ; X will be undefined from GETS^DIQ if field is null 7 ; added $G. 8 ;RVD - patch #77 use Fileman to set items that are not Primary item 9 ; to 'N' in order to set correctly the 'AC' cross-ref. 10 Q 11 UNLOCK I $D(RMPODFN) L -^RMPR(665,RMPODFN) 12 Q 13 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 14 D UNLOCK 15 Q 16 ; 17 KEY ;user must have the RMPRSUPERVISOR key in order to add a new patient. 18 ;option name is EDIT HOME OXYGEN PATIENT 19 N KEY 20 S KEY=$O(^DIC(19.1,"B","RMPRSUPERVISOR",0)) 21 I '$D(^VA(200,DUZ,51,KEY)) D Q 22 . W !!,"You do not hold the RMPSUPERVISOR key!!" 23 G PAT 24 ; 25 SITE ; Editing of Home Oxygen site parameter file. 26 K DIC,DIE,DA,DR,DD,RMPOXITE 27 S DIC="^RMPR(669.9,",DIC(0)="QEAMLZ",DIC("A")="Select SITE: " 28 D ^DIC Q:Y<0!$$QUIT 29 K DIC("A") 30 S (DA,RMPOXITE)=+Y 31 ; Lock it... 32 L +^RMPR(669.9,RMPOXITE):2 33 I '$T D G SITE 34 . W ?10,$C(7)_Y(0,0)_" -- record in use. Try again later." 35 ; Edit it 36 S DIE=DIC,DR="60;61;62;65" D ^DIE Q:$$EQUIT 37 ; Edit FCP 38 K DIC,DA,DD,DR,DIE 39 ; 40 ; Done. Unlock 41 L -^RMPR(669.9,RMPOXITE) 42 G SITE 43 ; 44 FCPHLP ; Executable help for FCP multiple in 669.9 45 ; 46 Q 47 FCPIX ; Input transform for FCP multiple in 669.9 48 ; 49 Q:'$D(X) 50 I $L(X)>30!($L(X)<3) K X Q 51 S ZST=$P(^RMPR(669.9,D0,4),U,1),RMPOX=X 52 D FIND^DIC(420.01,","_ZST_",",".01;","M",X,1,,,,"X") 53 S X=$S($D(X("DILIST","ID",1,.01)):X("DILIST","ID",1,.01),1:RMPOX) 54 K X("DILIST"),RMPOX 55 I $G(ZST),('$D(^PRC(420,+ZST,1,"B",X))) W !,"Control Point is not a valid IFCAP FCP.." K X 56 Q 57 ACT ;activate/inactivate a home oxygen patient 58 ;Set up site variables. 59 D HOSITE^RMPOUTL0 I QUIT D EXIT Q 60 W @IOF 61 ; 62 ACT1 ;Toggle ACTIVATE/INACTIVATE functions. 63 N NAME K DIC,DA 64 S DIC="^RMPR(665,",DIC(0)="QEAMZ" D ^DIC I Y<0!$$QUIT D EXIT Q 65 S DIE=DIC,DA=+Y,NAME=Y(0,0) 66 L +^RMPR(665,DA):2 67 I '$T D G ACT1 68 . W ?10,$C(7)_Y(0,0)_" -- record in use. Try later." 69 ;If the patient has never been activated, quit. 70 I $P($G(^RMPR(665,DA,"RMPOA")),U,2)="" D G ACT1 71 . W !!,$C(7)_NAME_" has not been added as a Home Oxygen patient." 72 . W !,"Please add using the ""Add/Edit Home Oxygen Patient"" option." 73 ;If the patient is active, perform inactivation actions. 74 I $P($G(^RMPR(665,DA,"RMPOA")),U,3)="" D INACTVT^RMPOPED G ACT1 75 ;If the patient is inactive, perform activation actions. 76 I $P($G(^RMPR(665,DA,"RMPOA")),U,3)'="" D ACTVT^RMPOPED G ACT1 77 Q 78 INACTVT ; Inactivate the patient if user wants to. 79 ; Confirm if the user wants to proceed. 80 K DIR S DIR(0)="YO",DIR("B")="NO" 81 S DIR("A")="Are you sure you want to inactivate "_NAME_" ?" D ^DIR 82 Q:(Y<1)!$$QUIT 83 S DR="19.5//TODAY;19.6;19.7////"_DUZ,DIE("NO^")="BACK" 84 D ^DIE 85 Q 86 ; 87 ACTVT ;Activate the patient if the user wants to. 88 K DIR S DIR(0)="YO",DIR("B")="NO" 89 S DIR("A")="Are you sure you want to reactivate "_NAME_" ?" D ^DIR 90 Q:(Y<1)!$$QUIT 91 S DR="19.2//TODAY;19.5///@;19.6///@;19.7///@" 92 S DIE("NO^")="BACK" 93 D ^DIE 94 Q 95 PAT ;Add/Edit Home Oxygen Patient 96 S QUIT=0 97 D HOSITE^RMPOUTL0 98 I '$D(RMPOXITE)!QUIT D EXIT Q 99 LOOP ; 100 S QUIT=0 101 D LOOKUP I QUIT!'$D(RMPODFN) D EXIT Q 102 D EDBLK I QUIT D EXIT Q 103 D UNLOCK G LOOP 104 EDBLK ; 105 D SITECHK Q:QUIT 106 D DEMOG Q:QUIT 107 D RX Q:QUIT 108 D ITEM 109 Q 110 ;called by ^RMPOBIL1, providing RMPOPATN as the X variable 111 EDIT ;From Billing... 112 I '$D(RMPODFN) S RMPODFN=$TR($G(RMPOPATN),"`") 113 Q:'$D(^RMPR(665,+RMPODFN,0)) 114 W !,"EDITING "_$P(^DPT(RMPODFN,0),U)_"...",! 115 S QUIT=0,DA=RMPODFN 116 L +^RMPR(665,DA):2 117 I '$T W !!?10,*7," << Record in use. Try later. >>" Q 118 D EDBLK,EXIT 119 Q 120 LOOKUP ;First look-up the patient 121 K DIC,DIE,DA,DR,RMPODFN 122 W !!! S DIC="^RMPR(665,",DIC(0)="LQEAMZ" 123 D ^DIC Q:(Y<0)!$$QUIT 124 CONT S (RMPODFN,DA)=+Y 125 L +^RMPR(665,DA):2 126 I '$T W !!?10,*7," << Record in use. Try later. >>" G LOOKUP 127 Q 128 ; 129 QUIT() S QUIT=$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q QUIT 130 EQUIT() S QUIT=$D(DTOUT)!$D(Y) Q QUIT 131 LJ(S,W,C) ; LEFT JUSTIFY S IN A FIELD W WIDE PADDING WITH CHAR F 132 ; 133 S C=$G(C," ") ;DEFAULT PAD CHAR IS SPACE 134 S $P(S,C,W-$L(S)+$L(S,C))="" 135 Q S 136 ; 137 SITECHK ;If user chooses patient from site different from billing site 138 ; 139 S Y=$P($G(^RMPR(665,RMPODFN,"RMPOA")),U,7) 140 Q:Y=RMPOXITE ;Site is the same.. 141 I Y="" D SET Q ;Site not defined, stuff RMPOXITE... 142 ; Site is different... 143 S IENS=RMPODFN_"," 144 D GETS^DIQ(665,IENS,19.12,"E","X") 145 W !!,"Patient's Home Oxygen Contract Location (HOCL) is " 146 W $G(X(665,IENS,19.12,"E")) 147 W !,"You are working on billing for HOCL "_RMPO("NAME"),! 148 K DIR S DIR(0)="Y",DIR("B")="NO" 149 S DIR("A")="Should I change this patient's HOCL to "_RMPO("NAME") 150 D ^DIR Q:$$QUIT!(Y=0) 151 D SET 152 Q 153 SET ; 154 K DIE,DR,DA 155 S DA=RMPODFN 156 ;W "HERE,RMPOXITE=",RMPOXITE 157 S DIE="^RMPR(665,",DR="19.12////"_RMPOXITE D ^DIE 158 Q 159 ; 160 DEMOG ;First edit the patient's basic fields 161 ; 162 K DIE,DR,DA 163 S DA=RMPODFN 164 S DIE="^RMPR(665,",DR="19.1" D ^DIE Q:$$EQUIT 165 S RMPOELIG=$P($G(^RMPR(665,RMPODFN,"RMPOA")),U) 166 K DR S DR="19.11"_$S(RMPOELIG="D":"",1:"///@")_";19.12" 167 D ^DIE Q:$$EQUIT 168 K DR S Y=DT X ^DD("DD") S DR="19.2//"_Y D ^DIE Q:$$QUIT 169 Q 170 ; 171 RX ;Edit the Rx Data 172 ; 173 N RXD,RXDI 174 K DIC,DIE,DA,DR 175 S DIC="^RMPR(665,"_RMPODFN_",""RMPOB"",",DIC(0)="AEQLZ" 176 S DA(1)=RMPODFN,DIC("P")="665.193D" 177 S RXD=$O(^RMPR(665,DA(1),"RMPOB","B",""),-1) D:RXD 178 . S DIC("B")=$$FMTE^XLFDT(RXD) 179 D ^DIC Q:Y<0!$$QUIT 180 S DIE=DIC,DA=+Y,DR=".01;2//^D EXPIRE^RMPOBIL4;3" D ^DIE Q:$$EQUIT 181 Q 182 ; 183 ITEM ;Add/Edit Items 184 ; 185 ; Display items 186 D ITEMD 187 ; If no items on file, then only allow ADD PRIMARY ITEM 188 I '$D(IEN) D ITEMP Q:QUIT!(ITEM="") G ITEM 189 ; ask for ACTION, quit if <return>, timeout, etc 190 S ITMACT=$$ITEMO Q:$$QUIT!(ITMACT="") 191 ; if they entered 'A', do ADD ITEM, then edit it 192 I ITMACT="A" D ITEMA Q:QUIT!(ITEM="") D ITEME Q:QUIT G ITEM 193 ; if they entered 'D', select an item, then delete it 194 I ITMACT="D" D ITEMS Q:QUIT!(ITEM="") D ITEMK G ITEM 195 ; if they entered 'E', select an item, then edit it 196 I ITMACT="E" D ITEMS Q:QUIT!(ITEM="") D ITEME Q:QUIT G ITEM 197 G ITEM 198 Q 199 ITEMP ; Add Primary Item 200 W !!,$C(7)_"No items found, please enter PRIMARY ITEM",! 201 D ITEMA Q:QUIT!(ITEM="") 202 S PI="///Y" D ITEME K PI 203 Q 204 ITEMA ; Add Items 205 S ITEM="" 206 K DIC S DIC="^RMPR(661,",DIC(0)="AEQMZ" D ^DIC Q:Y<0!$$QUIT 207 K DD,DO,DA,DIC 208 S DIC="^RMPR(665,"_RMPODFN_",""RMPOC"",",DIC(0)="L" 209 S DIC("P")=$P(^DD(665,19.4,0),U,2),DA(1)=RMPODFN,X=+Y 210 D FILE^DICN I Y>0 S IEN=$G(IEN)+1,IEN(IEN)=+Y,ITEM=IEN 211 Q 212 ITEMS ; Select Item 213 ; Return ITEM = index into both ITEMS and IEN arrays 214 I IEN=1 S ITEM=1 W " ",$E(ITEMS(1),1,33) Q 215 K DIR 216 S ITEM="" 217 S DIR(0)="NO^1:"_IEN,DIR("A")="Select an ITEM" 218 S DIR("?")="Select an item from the list" 219 M DIR("?")=ITEMS 220 D ^DIR Q:Y'>0!$$QUIT 221 S ITEM=+Y W " ",$E(ITEMS(ITEM),1,33) 222 Q 223 ITEME ; Edit an Item 224 N FCP,DFCP,RMCPTHCP,RMCPRENT K DIE,DA,DR,RMCPT 225 S DA(1)=RMPODFN,DA=IEN(ITEM),DIE="^RMPR(665,"_DA(1)_",""RMPOC""," 226 D ITEMEP Q:QUIT 227 S DR=".01R;6R" D ^DIE Q:$$EQUIT!('$D(DA)) 228 S RMCPTHCP=$P($G(^RMPR(665,RMPODFN,"RMPOC",DA,0)),U,7) 229 S RMCPT=$P($G(^RMPR(661.1,RMCPTHCP,4)),U,1) S DR="" 230 S RMCPRENT=$P($G(^RMPR(661.1,RMCPTHCP,5)),U,1) 231 I RMCPT["RR",(RMCPRENT=1) S DR="11;" 232 I RMCPT["QH" S DR=DR_"12;" 233 S DR=DR_"1R;2R;3R;4;7;8;9R" K RMCPRENT,RMCPTHCP 234 D ^DIE I $D(DA),$D(RMCPT),(RMCPT'["RR") S $P(^RMPR(665,DA(1),"RMPOC",DA,0),U,12)="" 235 I $D(DA),$D(RMCPT),(RMCPT'["QH") S $P(^RMPR(665,DA(1),"RMPOC",DA,0),U,13)="" 236 Q:$$EQUIT 237 ; Kludge to "point" to file 420 238 S DFCP=$P(^RMPR(665,RMPODFN,"RMPOC",IEN(ITEM),0),U,6) 239 F D Q:(FCP>0)!QUIT 240 . S FCP=$$GETFCP^RMPOBILU(DFCP) Q:QUIT 241 . I FCP<0 W $C(7)_"REQUIRED FIELD!" 242 I FCP>0 S DR="5///"_$P(FCP,U,2) D ^DIE Q:$$EQUIT 243 ; End Kludge 244 ;S DR="7:9" D ^DIE Q:$$EQUIT 245 Q 246 ITEMEP ; Primary Item edit... 247 N PIEN,PFLG,RMDA,RMNO 248 S RMDA=DA,DR="10" D ^DIE Q:$$QUIT 249 I $P(^RMPR(665,RMPODFN,"RMPOC",RMDA,0),U,11)'="Y" Q 250 ; Logic to control toggling of Primary Item flag... 251 S RMNO="N" 252 F RMX=0:0 S RMX=$O(^RMPR(665,RMPODFN,"RMPOC",RMX)) Q:RMX'>0 D 253 . Q:RMDA=RMX 254 . S DA=RMX,DR="10///^S X=RMNO" D ^DIE 255 S DA=RMDA 256 Q 257 PIEN(DFN) ; FIND PRIMARY ITEM 258 ; RETURN IEN OF P.I. IN MULTIPLE ^ IEN IN FILE 661 259 N X,PIEN 260 S X=0,PIEN=0 261 F S X=$O(^RMPR(665,DFN,"RMPOC",X)) Q:X'>0 D Q:PIEN 262 . S:$P(^RMPR(665,DFN,"RMPOC",X,0),U,11)="Y" PIEN=X 263 S:PIEN PIEN=PIEN_U_$P(^RMPR(665,DFN,"RMPOC",PIEN,0),U,1) 264 Q PIEN 265 ITEMD ; Display Items 266 N I,Z,PIF,ITMNM,VDRNM 267 K IEN,ITEMS S I=0 268 Q:$O(^RMPR(665,RMPODFN,"RMPOC",0))'>0 269 W !!,"The following items are already in this patient's template:",! 270 F IEN=1:1 S I=$O(^RMPR(665,RMPODFN,"RMPOC",I)) Q:I'>0 D 271 . S Z=^RMPR(665,RMPODFN,"RMPOC",I,0) 272 . S PIF=$S($P(Z,U,11)="Y":"*",1:" ") 273 . S ITMNM=$$ITEMNM($P(Z,U)),VDRNM=$$VDRNM($P(Z,U,2)) 274 .; K X S IENS=$P(Z,U)_"," 275 .; D GETS^DIQ(661,IENS,.01,"","X") S ITMNM=$E(X(661,IENS,.01),1,33) 276 .; S IENS=$P(Z,U,2)_",",VDRNM="<< VENDOR NOT DEFINED >>" 277 .; I IENS'="," D GETS^DIQ(440,IENS,.01,"","X") S VDRNM=X(440,IENS,.01) 278 . S IEN(IEN)=I 279 . S ITEMS(IEN)=" "_PIF_$J(IEN,4)_" "_$$LJ(ITMNM,38)_$E(VDRNM,1,30) 280 . W !,ITEMS(IEN) 281 W !!," * = Primary Item",! 282 S IEN=IEN-1 283 Q 284 ITEMNM(ITM) ; RETURN ITEM NAME 285 S IENS=ITM_"," 286 D GETS^DIQ(661,IENS,.01,"","X") 287 Q $E(X(661,IENS,.01),1,33) 288 VDRNM(VDR) ; RETURN VENDOR NAME 289 I VDR="" Q "<< VENDOR NOT DEFINED >>" 290 S IENS=VDR_"," D GETS^DIQ(440,IENS,.01,"","X") 291 Q X(440,IENS,.01) 292 ITEMK ; Delete an Item 293 ; 294 K DIR S DIR(0)="Y",DIR("A")="Are you SURE you want to delete this item" 295 S DIR("B")="NO" D ^DIR Q:Y'>0 296 K DIK,DA 297 S DA(1)=RMPODFN,DA=IEN(ITEM),DIK="^RMPR(665,"_DA(1)_",""RMPOC""," 298 D ^DIK W " ...deleted!" 299 Q 300 ITEMO() ; Choose Option 301 K DIR 302 S DIR(0)="SBO^A:Add;D:Delete;E:Edit",DIR("A")="Select ACTION" D ^DIR 303 Q Y 304 Q 1 RMPOPED ;EDS/MDB,DDW,RVD - HOME OXYGEN MISC FILE EDITS ;7/24/98 2 ;;3.0;PROSTHETICS;**29,44,41,52,77,110**;Feb 09, 1996;Build 10 3 ; 4 ; HNC - patch 52 5 ; modified SITECHK sub 6 ; X will be undefined from GETS^DIQ if field is null 7 ; added $G. 8 ;RVD - patch #77 use Fileman to set items that are not Primary item 9 ; to 'N' in order to set correctly the 'AC' cross-ref. 10 Q 11 UNLOCK I $D(RMPODFN) L -^RMPR(665,RMPODFN) 12 Q 13 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 14 D UNLOCK 15 Q 16 ; 17 KEY ;user must have the RMPRSUPERVISOR key in order to add a new patient. 18 ;option name is EDIT HOME OXYGEN PATIENT 19 N KEY 20 S KEY=$O(^DIC(19.1,"B","RMPRSUPERVISOR",0)) 21 I '$D(^VA(200,DUZ,51,KEY)) D Q 22 . W !!,"You do not hold the RMPSUPERVISOR key!!" 23 G PAT 24 ; 25 SITE ; Editing of Home Oxygen site parameter file. 26 K DIC,DIE,DA,DR,DD,RMPOXITE 27 S DIC="^RMPR(669.9,",DIC(0)="QEAMLZ",DIC("A")="Select SITE: " 28 D ^DIC Q:Y<0!$$QUIT 29 K DIC("A") 30 S (DA,RMPOXITE)=+Y 31 ; Lock it... 32 L +^RMPR(669.9,RMPOXITE):2 33 I '$T D G SITE 34 . W ?10,$C(7)_Y(0,0)_" -- record in use. Try again later." 35 ; Edit it 36 S DIE=DIC,DR="60;61;62;65" D ^DIE Q:$$EQUIT 37 ; Edit FCP 38 K DIC,DA,DD,DR,DIE 39 ; 40 ; Done. Unlock 41 L -^RMPR(669.9,RMPOXITE) 42 G SITE 43 ; 44 FCPHLP ; Executable help for FCP multiple in 669.9 45 ; 46 Q 47 FCPIX ; Input transform for FCP multiple in 669.9 48 ; 49 Q:'$D(X) 50 I $L(X)>30!($L(X)<3) K X Q 51 S ZST=$P(^RMPR(669.9,D0,4),U,1),RMPOX=X 52 D FIND^DIC(420.01,","_ZST_",",".01;","M",X,1,,,,"X") 53 S X=$S($D(X("DILIST","ID",1,.01)):X("DILIST","ID",1,.01),1:RMPOX) 54 K X("DILIST"),RMPOX 55 I $G(ZST),('$D(^PRC(420,+ZST,1,"B",X))) W !,"Control Point is not a valid IFCAP FCP.." K X 56 Q 57 ACT ;activate/inactivate a home oxygen patient 58 ;Set up site variables. 59 D HOSITE^RMPOUTL0 I QUIT D EXIT Q 60 W @IOF 61 ; 62 ACT1 ;Toggle ACTIVATE/INACTIVATE functions. 63 N NAME K DIC,DA 64 S DIC="^RMPR(665,",DIC(0)="QEAMZ" D ^DIC I Y<0!$$QUIT D EXIT Q 65 S DIE=DIC,DA=+Y,NAME=Y(0,0) 66 L +^RMPR(665,DA):2 67 I '$T D G ACT1 68 . W ?10,$C(7)_Y(0,0)_" -- record in use. Try later." 69 ;If the patient has never been activated, quit. 70 I $P($G(^RMPR(665,DA,"RMPOA")),U,2)="" D G ACT1 71 . W !!,$C(7)_NAME_" has not been added as a Home Oxygen patient." 72 . W !,"Please add using the ""Add/Edit Home Oxygen Patient"" option." 73 ;If the patient is active, perform inactivation actions. 74 I $P($G(^RMPR(665,DA,"RMPOA")),U,3)="" D INACTVT^RMPOPED G ACT1 75 ;If the patient is inactive, perform activation actions. 76 I $P($G(^RMPR(665,DA,"RMPOA")),U,3)'="" D ACTVT^RMPOPED G ACT1 77 Q 78 INACTVT ; Inactivate the patient if user wants to. 79 ; Confirm if the user wants to proceed. 80 K DIR S DIR(0)="YO",DIR("B")="NO" 81 S DIR("A")="Are you sure you want to inactivate "_NAME_" ?" D ^DIR 82 Q:(Y<1)!$$QUIT 83 S DR="19.5//TODAY;19.6;19.7////"_DUZ,DIE("NO^")="BACK" 84 D ^DIE 85 Q 86 ; 87 ACTVT ;Activate the patient if the user wants to. 88 K DIR S DIR(0)="YO",DIR("B")="NO" 89 S DIR("A")="Are you sure you want to reactivate "_NAME_" ?" D ^DIR 90 Q:(Y<1)!$$QUIT 91 S DR="19.2//TODAY;19.5///@;19.6///@;19.7///@" 92 S DIE("NO^")="BACK" 93 D ^DIE 94 Q 95 PAT ;Add/Edit Home Oxygen Patient 96 S QUIT=0 97 D HOSITE^RMPOUTL0 98 I '$D(RMPOXITE)!QUIT D EXIT Q 99 LOOP ; 100 S QUIT=0 101 D LOOKUP I QUIT!'$D(RMPODFN) D EXIT Q 102 D EDBLK I QUIT D EXIT Q 103 D UNLOCK G LOOP 104 EDBLK ; 105 D SITECHK Q:QUIT 106 D DEMOG Q:QUIT 107 D RX Q:QUIT 108 D ITEM 109 Q 110 ;called by ^RMPOBIL1, providing RMPOPATN as the X variable 111 EDIT ;From Billing... 112 I '$D(RMPODFN) S RMPODFN=$TR($G(RMPOPATN),"`") 113 Q:'$D(^RMPR(665,+RMPODFN,0)) 114 W !,"EDITING "_$P(^DPT(RMPODFN,0),U)_"...",! 115 S QUIT=0,DA=RMPODFN 116 L +^RMPR(665,DA):2 117 I '$T W !!?10,*7," << Record in use. Try later. >>" Q 118 D EDBLK,EXIT 119 Q 120 LOOKUP ;First look-up the patient 121 K DIC,DIE,DA,DR,RMPODFN 122 W !!! S DIC="^RMPR(665,",DIC(0)="LQEAMZ" 123 D ^DIC Q:(Y<0)!$$QUIT 124 CONT S (RMPODFN,DA)=+Y 125 L +^RMPR(665,DA):2 126 I '$T W !!?10,*7," << Record in use. Try later. >>" G LOOKUP 127 Q 128 ; 129 QUIT() S QUIT=$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q QUIT 130 EQUIT() S QUIT=$D(DTOUT)!$D(Y) Q QUIT 131 LJ(S,W,C) ; LEFT JUSTIFY S IN A FIELD W WIDE PADDING WITH CHAR F 132 ; 133 S C=$G(C," ") ;DEFAULT PAD CHAR IS SPACE 134 S $P(S,C,W-$L(S)+$L(S,C))="" 135 Q S 136 ; 137 SITECHK ;If user chooses patient from site different from billing site 138 ; 139 S Y=$P($G(^RMPR(665,RMPODFN,"RMPOA")),U,7) 140 Q:Y=RMPOXITE ;Site is the same.. 141 I Y="" D SET Q ;Site not defined, stuff RMPOXITE... 142 ; Site is different... 143 S IENS=RMPODFN_"," 144 D GETS^DIQ(665,IENS,19.12,"E","X") 145 W !!,"Patient's Home Oxygen Contract Location (HOCL) is " 146 W $G(X(665,IENS,19.12,"E")) 147 W !,"You are working on billing for HOCL "_RMPO("NAME"),! 148 K DIR S DIR(0)="Y",DIR("B")="NO" 149 S DIR("A")="Should I change this patient's HOCL to "_RMPO("NAME") 150 D ^DIR Q:$$QUIT!(Y=0) 151 D SET 152 Q 153 SET ; 154 K DIE,DR,DA 155 S DA=RMPODFN 156 ;W "HERE,RMPOXITE=",RMPOXITE 157 S DIE="^RMPR(665,",DR="19.12////"_RMPOXITE D ^DIE 158 Q 159 ; 160 DEMOG ;First edit the patient's basic fields 161 ; 162 K DIE,DR,DA 163 S DA=RMPODFN 164 S DIE="^RMPR(665,",DR="19.1" D ^DIE Q:$$EQUIT 165 S RMPOELIG=$P($G(^RMPR(665,RMPODFN,"RMPOA")),U) 166 K DR S DR="19.11"_$S(RMPOELIG="D":"",1:"///@")_";19.12" 167 D ^DIE Q:$$EQUIT 168 K DR S Y=DT X ^DD("DD") S DR="19.2//"_Y D ^DIE Q:$$QUIT 169 Q 170 ; 171 RX ;Edit the Rx Data 172 ; 173 K DIC,DIE,DA,DR 174 S DIC="^RMPR(665,"_RMPODFN_",""RMPOB"",",DIC(0)="AEQLZ" 175 S DA(1)=RMPODFN,DIC("P")="665.193D" 176 I $D(^DISV(DUZ,DIC)) S Y=^(DIC) I $D(@(DIC_(+Y)_",0)")) D 177 . S DIC("B")=$P(^(0),U,1) 178 D ^DIC Q:Y<0!$$QUIT 179 S DIE=DIC,DA=+Y,DR=".01;2//^D EXPIRE^RMPOBIL4;3" D ^DIE Q:$$EQUIT 180 Q 181 ; 182 ITEM ;Add/Edit Items 183 ; 184 ; Display items 185 D ITEMD 186 ; If no items on file, then only allow ADD PRIMARY ITEM 187 I '$D(IEN) D ITEMP Q:QUIT!(ITEM="") G ITEM 188 ; ask for ACTION, quit if <return>, timeout, etc 189 S ITMACT=$$ITEMO Q:$$QUIT!(ITMACT="") 190 ; if they entered 'A', do ADD ITEM, then edit it 191 I ITMACT="A" D ITEMA Q:QUIT!(ITEM="") D ITEME Q:QUIT G ITEM 192 ; if they entered 'D', select an item, then delete it 193 I ITMACT="D" D ITEMS Q:QUIT!(ITEM="") D ITEMK G ITEM 194 ; if they entered 'E', select an item, then edit it 195 I ITMACT="E" D ITEMS Q:QUIT!(ITEM="") D ITEME Q:QUIT G ITEM 196 G ITEM 197 Q 198 ITEMP ; Add Primary Item 199 W !!,$C(7)_"No items found, please enter PRIMARY ITEM",! 200 D ITEMA Q:QUIT!(ITEM="") 201 S PI="///Y" D ITEME K PI 202 Q 203 ITEMA ; Add Items 204 S ITEM="" 205 K DIC S DIC="^RMPR(661,",DIC(0)="AEQMZ" D ^DIC Q:Y<0!$$QUIT 206 K DD,DO,DA,DIC 207 S DIC="^RMPR(665,"_RMPODFN_",""RMPOC"",",DIC(0)="L" 208 S DIC("P")=$P(^DD(665,19.4,0),U,2),DA(1)=RMPODFN,X=+Y 209 D FILE^DICN I Y>0 S IEN=$G(IEN)+1,IEN(IEN)=+Y,ITEM=IEN 210 Q 211 ITEMS ; Select Item 212 ; Return ITEM = index into both ITEMS and IEN arrays 213 I IEN=1 S ITEM=1 W " ",$E(ITEMS(1),1,33) Q 214 K DIR 215 S ITEM="" 216 S DIR(0)="NO^1:"_IEN,DIR("A")="Select an ITEM" 217 S DIR("?")="Select an item from the list" 218 M DIR("?")=ITEMS 219 D ^DIR Q:Y'>0!$$QUIT 220 S ITEM=+Y W " ",$E(ITEMS(ITEM),1,33) 221 Q 222 ITEME ; Edit an Item 223 N FCP,DFCP,RMCPTHCP,RMCPRENT K DIE,DA,DR,RMCPT 224 S DA(1)=RMPODFN,DA=IEN(ITEM),DIE="^RMPR(665,"_DA(1)_",""RMPOC""," 225 D ITEMEP Q:QUIT 226 S DR=".01R;6R" D ^DIE Q:$$EQUIT!('$D(DA)) 227 S RMCPTHCP=$P($G(^RMPR(665,RMPODFN,"RMPOC",DA,0)),U,7) 228 S RMCPT=$P($G(^RMPR(661.1,RMCPTHCP,4)),U,1) S DR="" 229 S RMCPRENT=$P($G(^RMPR(661.1,RMCPTHCP,5)),U,1) 230 I RMCPT["RR",(RMCPRENT=1) S DR="11;" 231 I RMCPT["QH" S DR=DR_"12;" 232 S DR=DR_"1R;2R;3R;4;7;8;9R" K RMCPRENT,RMCPTHCP 233 D ^DIE I $D(DA),$D(RMCPT),(RMCPT'["RR") S $P(^RMPR(665,DA(1),"RMPOC",DA,0),U,12)="" 234 I $D(DA),$D(RMCPT),(RMCPT'["QH") S $P(^RMPR(665,DA(1),"RMPOC",DA,0),U,13)="" 235 Q:$$EQUIT 236 ; Kludge to "point" to file 420 237 S DFCP=$P(^RMPR(665,RMPODFN,"RMPOC",IEN(ITEM),0),U,6) 238 F D Q:(FCP>0)!QUIT 239 . S FCP=$$GETFCP^RMPOBILU(DFCP) Q:QUIT 240 . I FCP<0 W $C(7)_"REQUIRED FIELD!" 241 I FCP>0 S DR="5///"_$P(FCP,U,2) D ^DIE Q:$$EQUIT 242 ; End Kludge 243 ;S DR="7:9" D ^DIE Q:$$EQUIT 244 Q 245 ITEMEP ; Primary Item edit... 246 N PIEN,PFLG,RMDA,RMNO 247 S RMDA=DA,DR="10" D ^DIE Q:$$QUIT 248 I $P(^RMPR(665,RMPODFN,"RMPOC",RMDA,0),U,11)'="Y" Q 249 ; Logic to control toggling of Primary Item flag... 250 S RMNO="N" 251 F RMX=0:0 S RMX=$O(^RMPR(665,RMPODFN,"RMPOC",RMX)) Q:RMX'>0 D 252 . Q:RMDA=RMX 253 . S DA=RMX,DR="10///^S X=RMNO" D ^DIE 254 S DA=RMDA 255 Q 256 PIEN(DFN) ; FIND PRIMARY ITEM 257 ; RETURN IEN OF P.I. IN MULTIPLE ^ IEN IN FILE 661 258 N X,PIEN 259 S X=0,PIEN=0 260 F S X=$O(^RMPR(665,DFN,"RMPOC",X)) Q:X'>0 D Q:PIEN 261 . S:$P(^RMPR(665,DFN,"RMPOC",X,0),U,11)="Y" PIEN=X 262 S:PIEN PIEN=PIEN_U_$P(^RMPR(665,DFN,"RMPOC",PIEN,0),U,1) 263 Q PIEN 264 ITEMD ; Display Items 265 N I,Z,PIF,ITMNM,VDRNM 266 K IEN,ITEMS S I=0 267 Q:$O(^RMPR(665,RMPODFN,"RMPOC",0))'>0 268 W !!,"The following items are already in this patient's template:",! 269 F IEN=1:1 S I=$O(^RMPR(665,RMPODFN,"RMPOC",I)) Q:I'>0 D 270 . S Z=^RMPR(665,RMPODFN,"RMPOC",I,0) 271 . S PIF=$S($P(Z,U,11)="Y":"*",1:" ") 272 . S ITMNM=$$ITEMNM($P(Z,U)),VDRNM=$$VDRNM($P(Z,U,2)) 273 .; K X S IENS=$P(Z,U)_"," 274 .; D GETS^DIQ(661,IENS,.01,"","X") S ITMNM=$E(X(661,IENS,.01),1,33) 275 .; S IENS=$P(Z,U,2)_",",VDRNM="<< VENDOR NOT DEFINED >>" 276 .; I IENS'="," D GETS^DIQ(440,IENS,.01,"","X") S VDRNM=X(440,IENS,.01) 277 . S IEN(IEN)=I 278 . S ITEMS(IEN)=" "_PIF_$J(IEN,4)_" "_$$LJ(ITMNM,38)_$E(VDRNM,1,30) 279 . W !,ITEMS(IEN) 280 W !!," * = Primary Item",! 281 S IEN=IEN-1 282 Q 283 ITEMNM(ITM) ; RETURN ITEM NAME 284 S IENS=ITM_"," 285 D GETS^DIQ(661,IENS,.01,"","X") 286 Q $E(X(661,IENS,.01),1,33) 287 VDRNM(VDR) ; RETURN VENDOR NAME 288 I VDR="" Q "<< VENDOR NOT DEFINED >>" 289 S IENS=VDR_"," D GETS^DIQ(440,IENS,.01,"","X") 290 Q X(440,IENS,.01) 291 ITEMK ; Delete an Item 292 ; 293 K DIR S DIR(0)="Y",DIR("A")="Are you SURE you want to delete this item" 294 S DIR("B")="NO" D ^DIR Q:Y'>0 295 K DIK,DA 296 S DA(1)=RMPODFN,DA=IEN(ITEM),DIK="^RMPR(665,"_DA(1)_",""RMPOC""," 297 D ^DIK W " ...deleted!" 298 Q 299 ITEMO() ; Choose Option 300 K DIR 301 S DIR(0)="SBO^A:Add;D:Delete;E:Edit",DIR("A")="Select ACTION" D ^DIR 302 Q Y 303 Q
Note:
See TracChangeset
for help on using the changeset viewer.
