source: FOIAVistA/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFET84.m@ 632

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

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1RMPFET84 ;DDC/KAW-CERTIFY A CUSTOM HEARING AID RECEIPT [ 06/16/95 3:06 PM ]
2 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
3 S RMPFHAT="I",RMPFTP="P",RMPFTYP=5
4 D MSG G END:$D(RMPFOUT) S NB=11 D AUTH^RMPFET71 G END:$D(RMPFOUT)
5PAT W @IOF,!,"CERTIFY CUSTOM HEARING AIDS"
6 W ! S DIC=2,DIC(0)="AEQM" D ^DIC G END:Y=-1 S DFN=+Y K RMPFX
7 S (C,X)=0 F S X=$O(^RMPF(791810,"C",DFN,X)) Q:'X D
8 .S Y=0 F S Y=$O(^RMPF(791810,X,101,Y)) Q:'Y S S0=^(Y,0),X1=$P(S0,U,18) S:X1 X1=$P($G(^RMPF(791810.2,X1,0)),U,2) I "EDSF"[X1!($P(S0,U,19)["R"&$P(S0,U,20)) S RMPFX=X,C=C+1 Q
9 I '$D(RMPFX) W !!,"*** THERE ARE NO ORDERS TO BE CERTIFIED FOR THIS PATIENT ***" D CONT^RMPFEI G PAT
10 G PAT:'$D(RMPFX)
11 S X=$P(^RMPF(791810,RMPFX,0),U,3)
12MG1 I X="" W !!,"*** ERROR IN ORDER ***" G END
13 S X=$P($G(^RMPF(791810.2,X,0)),U,2) G MG1:X=""
14 I "DESPF"'[X W !!,"*** THE STATUS OF THIS ORDER DOES NOT PERMIT CERTIFICATION ***" D CONT^RMPFET G END:$D(RMPFOUT),PAT
15 D DISP0 G END:$D(RMPFOUT) D APPROV1^RMPFEA2 G END:$D(RMPFOUT),PAT
16DISP S NB=11 D AUTH^RMPFET71 Q:$D(RMPFOUT)
17DISP0 ;; input: RMPFX,DFN,RMPFHAT,RMPFTYP
18 ;;output: None
19DISP1 W @IOF,!?20,"CERTIFY RECEIPT OF A CUSTOM HEARING AID"
20 D PAT^RMPFUTL,HEADP1^RMPFDT1
21 W !! D ^RMPFDT2 K RMPFY D SEL G END:$D(RMPFOUT)
22 I RMPFSEL="" D ^RMPFET3 G END
23 I "Aa"[RMPFSEL D EN1^RMPFET8 G DISP1
24 S (A,BX)=0 F S A=$O(RMPFMD(A)) Q:'A I $D(^RMPF(791810,RMPFX,101,RMPFMD(A),0)) S S0=^(0),X=$P(S0,U,18) I X,$D(^RMPF(791810.2,X,0)),"DESPF"[$P(^(0),U,2)!($P(S0,U,19)["R"&$P(S0,U,20)) S BX=BX+1,MD=A
25 I 'BX W !!,"*** THERE ARE NO LINE ITEMS TO CERTIFY ***" H 2 G DISP1
26 I BX=1 S (FY,RMPFY)=RMPFMD(MD),PT=MD D ^RMPFET85 Q:$D(RMPFOUT) G DISP1:RMPFHAT="X" D ISSUE Q:$D(RMPFOUT)!('$D(Y)) S CK=BX D:"Yy"[Y ^RMPFET71 G DISP1
27ASK W !!,"Certify ",BX," orders? YES// " D READ G DISP1:$D(RMPFOUT)
28ASK1 I $D(RMPFQUT) W !!,"Enter a <Y> or <RETURN> to certify all orders in the status 'ISSUE DATE PENDING'",!?5,"an <N> to select a line item to certify." G ASK
29 S:Y="" Y="Y" S Y=$E(Y,1) I "NnYy"'[Y S RMPFQUT="" G ASK1
30 G CHOOSE:"Nn"[Y S MD=0
31LOOP S MD=$O(RMPFMD(MD)) G LOOP1:'MD S RMPFY=RMPFMD(MD)
32 G LOOP:'$D(^RMPF(791810,RMPFX,101,RMPFY,0)) S X=$P(^(0),U,18) G LOOP:'X,LOOP:'$D(^RMPF(791810.2,X,0)),LOOP:"DESPF"'[$P(^(0),U,2)
33 D ^RMPFET85 G LOOPE:$D(RMPFOUT),LOOP
34LOOP1 G LOOPE:RMPFHAT="X" D ISSUE G LOOPE:'$D(Y),LOOPE:"Yy"'[Y S MD=0
35LOOP2 S MD=$O(RMPFMD(MD)) G LOOPE:'MD S (FY,RMPFY)=RMPFMD(MD),PT=MD,CK=BX D ^RMPFET71 G LOOP2
36LOOPE K MD G DISP1
37CHOOSE W !!,"Select the number of the line item to certify: " D READ
38 Q:$D(RMPFOUT)
39CH1 I $D(RMPFQUT) W !!,"Enter the number to the left of the line item you wish to certify or <RETURN> to exit." G CHOOSE
40 Q:Y="" I '$D(RMPFMD(Y)) S RMPFQUT="" G CH1
41 S RMPFY=RMPFMD(Y),MD=Y D ^RMPFET85 G END:$D(RMPFOUT)
42 D ISSUE G END:$D(RMPFOUT),DISP1:'$D(Y),DISP1:"Yy"'[Y
43 S FY=RMPFY,PT=MD,CK=BX D ^RMPFET71 G END:$D(RMPFOUT),DISP1
44END K SX,X1,FL,SG,RMPFY1,Y,CX,BX,RMPFDOB,RMPFSSN,RMPFDOD,RMPFNAM,RMPFMD
45 K RMPFO,RMPFSEL,RMPFST,RMPFOUT,RMPFQUT,FX,NB,PT Q
46ISSUE S X=$G(^RMPF(791810,RMPFX,101,RMPFY,90)) Q:'$P(X,U,8)!('$P(X,U,9))
47 Q:$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,5)=""
48 W !!,"Do you wish to enter the issue information? NO// " D READ
49 Q:$D(RMPFOUT)
50I1 I $D(RMPFQUT) W !!,"Enter a <Y> to edit the issue information",!?5,"an <N> to exit." G ISSUE
51 S:Y="" Y="N" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G I1
52 Q
53READ K RMPFOUT,RMPFQUT
54 R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
55 I Y?1"^".E S (RMPFOUT,Y)="" Q
56 S:Y?1"?".E (RMPFQUT,Y)=""
57 Q
58SEL ;; input: RMPFO,RMPFMD,RMPFX
59 ;;output: RMPFSEL
60 S (X,FL)=0,FX="" F S X=$O(RMPFO(X)) Q:'X D Q:FL
61 .I '$P($G(^RMPF(791810,RMPFX,101,X,90)),U,9) S FL=1 Q
62 .S X1=$P(^RMPF(791810,RMPFX,101,X,0),U,18) I X1,$D(^RMPF(791810.2,X1,0)) S X1=$P(^(0),U,2) I "DEF"[X1 S FL=1 Q
63 .I $P(^RMPF(791810,RMPFX,101,X,0),U,19)["R"&$P(^(0),U,20) S FL=1
64 W !!,"Enter "
65 I FL W "<A>djust, <C>ertify or " S FX="CcAa"
66 W "<RETURN> to exit: " D READ Q:$D(RMPFOUT)
67SEL1 I $D(RMPFQUT) D MSG1 G SEL
68 S RMPFSEL=Y Q:RMPFSEL="" S RMPFSEL=$E(RMPFSEL,1)
69 I FX'="",FX'[RMPFSEL S RMPFQUT="" G SEL1
70 S X=$E(Y,2) I X,$D(RMPFMD(X)) S RMPFY=RMPFMD(X)
71 K X,Y,FL,FX Q
72MSG W @IOF,!!?21,"CUSTOM HEARING AID ORDER CERTIFICATION"
73 W !!!,"When you certify a custom hearing aid order please be absolutely sure that the"
74 W !,"ROES order exactly matches the aid and components that you received from"
75 W !,"the vendor. You are authorizing the DDC to pay for the order as it appears on"
76 W !,"your screen."
77 W !!,"If necessary you may use the adjustment procedure to adjust the order prior to",!,"certification."
78 D CONT^RMPFET
79 Q
80MSG1 W !!,"Enter an <A> to adjust the order (MUST BE DONE PRIOR TO CERTIFICATION)"
81 W !?7,"a <C> to certify the order"
82 Q
Note: See TracBrowser for help on using the repository browser.