source: FOIAVistA/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFET8.m@ 649

Last change on this file since 649 was 628, checked in by George Lilly, 16 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1RMPFET8 ;DDC/KAW-ADJUST AN ORDER [ 06/16/95 3:06 PM ]
2 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**17**;06/06/01
3 ;;input : RMPFX,DFN,RMPFTYP,RMPFHAT,RMPFTP
4 ;;output: None
5 Q:'$D(RMPFX) Q:'$D(DFN) Q:'DFN
6 W @IOF,!!,"ORDER ADJUSTMENTS"
7 W !!?32,"*** WARNING ***"
8 W !!,"This module is used to make adjustments to an order that has already been"
9 W !!,"sent to the DDC. Orders may be adjusted up to 60 working days after aids"
10 W !!,"are issued. If an adjustment is made after issue, the DDC will update the"
11 W !!,"the order with the status 'CERTIFICATION PENDING'. Certification will again"
12 W !!,"be required before the vendor will be paid."
13 D CONT^RMPFET G END:$D(RMPFOUT)
14EN1 S S0=^RMPF(791810,RMPFX,0) K RMPFADJ
15 I RMPFTYP,$D(^RMPF(791810.1,RMPFTYP,0)) S RMPFTYPP=$P(^(0),U,1)
16 I RMPFTYP=""!(RMPFHAT="") W $C(7),!!,"ERROR IN ORDER TYPE" G END
17 K RMPFSEL1
18EDIT D PAT^RMPFUTL,HEAD,^RMPFDT2
19 S (X,CT)=0 F I=1:1 S X=$O(RMPFO(X)) Q:'X S CT=CT+1
20 D SEL G END:$D(RMPFOUT),EDIT:$D(RMPFQUT),END:RMPFSEL1="",EDIT
21END K RMPFTYPP,CT,X,RMPFOUT,RMPFQUT,RMPFSEL1,RMPFADJ,RMPFDOD
22 K RMPFDOB,RMPFNAM,RMPFMD,RMPFO,RMPFSSN,CM,CX,DI,DIC,I,Y,RMPFRE Q
23SEL ;;Select adjustment action
24 ;; input: RMPFX,CT,RMPFMD
25 ;;output: RMPFSEL1
26 S RMPFODAT=$P(^RMPF(791810,RMPFX,0),"^",9)
27 I RMPFODAT>3010630 D
28 .W !!!,"Enter <C>hange Model, <H>istory or <RETURN> to continue: " D READ
29 I RMPFODAT<3010701 D
30 .W !!!,"Enter <C>hange Model, <R>emove Component, <A>dd Component,"
31 .W " <H>istory or <RETURN> to continue: " D READ
32 G SELE:$D(RMPFOUT)
33SEL1 I $D(RMPFQUT) D MSG G SELE:$D(RMPFOUT) S RMPFQUT="" G SELE
34 S RMPFSEL1=$E(Y,1) G SELE:RMPFSEL1=""
35 I RMPFODAT>3010630 I "CcHh"'[RMPFSEL1 S RMPFQUT="" G SEL1
36 I RMPFODAT<3010701 I "CcRrAaHh"'[RMPFSEL1 S RMPFQUT="" G SEL1
37 I "Hh"[RMPFSEL1 D ^RMPFDT7 G SELE
38 I CT=1,$P(^RMPF(791810,RMPFX,101,RMPFMD(1),0),U,15)'="C" S RMPFY=RMPFMD(1) G DO
39NUM S Z=$E(Y,2,99) G ITEM:'Z
40 I $D(RMPFMD(Z)),$P(^RMPF(791810,RMPFX,101,RMPFMD(Z),0),U,15)'="C" S RMPFY=RMPFMD(Z) G DO
41ITEM W !!,"Select number of item to adjust: " D READ G SELE:$D(RMPFOUT)
42ITEM1 I $D(RMPFQUT) W !!,"Enter the number to the left of the item that you wish to adjust." G ITEM
43 G SELE:Y="" I '$D(RMPFMD(Y)) S RMPFQUT="" G ITEM1
44 S RMPFY=RMPFMD(Y)
45 I $P(^RMPF(791810,RMPFX,101,RMPFY,0),U,15)="C" W $C(7),!!,"*** THIS ORDER HAS BEEN CANCELED ***" S RMPFQUT="" G ITEM1
46DO S X=$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,18) G SELE:'X,SELE:'$D(^RMPF(791810.2,X,0)) S X=$P(^(0),U,2) G SELE:X="" I "SECF"'[X W !!,$C(7),"*** LINE ITEMS WITH THIS STATUS CANNOT BE ADJUSTED ***" H 2 G SELE
47 I "Cc"[RMPFSEL1 D CHANGEM^RMPFET81 G END:$D(RMPFOUT)!'$D(RMPFY) D CERTIFY G END:$D(RMPFOUT),SELE
48 I RMPFODAT<3010701 I "Rr"[RMPFSEL1 D REMOVEC^RMPFET81 G END:$D(RMPFOUT)!'$D(RMPFY) D CERTIFY G END:$D(RMPFOUT),SELE
49 I RMPFODAT<3010701 I "Aa"[RMPFSEL1 D ADDC^RMPFET81 G END:$D(RMPFOUT)!'$D(RMPFY) D CERTIFY G END:$D(RMPFOUT),SELE
50SELE K X,Y,Z,RMPFMD,RMPFY Q
51READ K RMPFOUT,RMPFQUT
52 R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
53 I Y?1"^".E S (RMPFOUT,Y)="" Q
54 S:Y?1"?".E (RMPFQUT,Y)=""
55 Q
56HEAD W @IOF,!?27,"ACTIVE ORDER INFORMATION"
57 W !,"Station: ",RMPFSTAP,?68,RMPFDAT
58 W !,"Patient: ",$E(RMPFNAM,1,25),?40,"SSN: ",RMPFSSN,?62,"DOB: ",RMPFDOB
59 W ! F I=1:1:80 W "-"
60 Q
61CERTIFY S S0=^RMPF(791810,RMPFX,101,RMPFY,0)
62 Q:'$P(S0,U,20) Q:$P(S0,U,19)'["A"
63 Q:'$D(^RMPF(791810,RMPFX,101,RMPFY,90)) F I=8:1:11 S $P(^(90),U,I)=""
64 W !!,"*** THIS LINE ITEM MUST BE CERTIFIED ***"
65 S BX=1 D ^RMPFET85
66 Q
67MSG W !!,"Enter <C> to change a hearing aid model"
68 W:RMPFODAT<3010701 !?6,"<R> to remove a component from the order"
69 W:RMPFODAT<3010701 !?6,"<A> to add a component to the order"
70 W !?6,"<H> to view the history of the order actions"
71 W !?6,"<RETURN> to continue."
72 W !!,"If the order consists of more than one model, the number of the model needing to",!,"be adjusted may be entered after the letter from the command line (i.g., 'C2')."
73 W !!,"Enter <RETURN> to continue." D READ Q
74DELETE ;;Delete old model when changing models
75 ;; input: RMPFX,RMPFY,RMPFRE,RMPFMSG,RMPFY1
76 ;;output: None
77 S S0=^RMPF(791810,RMPFX,101,RMPFY1,0),IT=$P(S0,U,1)
78 S LR=$P(S0,U,4),CX=$P(S0,U,14),X="NOW",%DT="T" D ^%DT S TD=Y
79 S DIC="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DLAYGO=791810
80 S DIC(0)="L",X=""_IT_""
81 S DIC("DR")=".04////"_LR_";.14////"_CX_";.15////DC;.16////"_RMPFY1_";.18///APPROVED;90.01////"_DUZ_";90.02////"_TD_";90.03////"_RMPFRE_";90.04////"_RMPFMESG W "."
82 K DD,DO D FILE^DICN S RMPFY3=+Y
83 I Y=-1 W $C(7),!!,"*** MODEL NOT DELETED ***" H 2 Q
84 S RMPFY=RMPFY1 D ARRAY2^RMPFDT2
85 S RMPFZ=0 F IX=1:1 S RMPFZ=$O(RMPFC(RMPFZ)) Q:'RMPFZ W "." D
86 .S IT=$P(RMPFC(RMPFZ),U,1),CX=$P(RMPFC(RMPFZ),U,2)
87 .I '$D(^RMPF(791810,RMPFX,101,RMPFY3,102,0)) S ^RMPF(791810,RMPFX,101,RMPFY3,102,0)="^791810.101102P"
88 .S DIC="^RMPF(791810,"_RMPFX_",101,"_RMPFY3_",102,",X=""_IT_""
89 .S DA(2)=RMPFX,DA(1)=RMPFY3,DLAYGO=791810,DIC(0)="L"
90 .S DIC("DR")=".03////D;.05////"_DUZ_";.06////"_TD_";.07////"_RMPFRE
91 .K DO,DD D FILE^DICN I Y=-1 W $C(7),!!,"*** COMPONENT NOT DELETED ***" Q
92 .S $P(^RMPF(791810,RMPFX,101,RMPFY3,102,+Y,0),U,4)=+Y,$P(^(0),U,2)=CX Q
93 K X,Y,RMPFOUT,RMPFQUT,DIC,RMPFZ,RMPFC,IT,CX,DA,ZZ,ZY,RMPFRE,RMPFY3,TD
94 K LR,IX,%,%DT,D0,DI,DIE,DLAYGO,DQ,DR Q
Note: See TracBrowser for help on using the repository browser.