| 1 | RMPFET71 ;DDC/KAW-CONTINUATION OF RMPFT7 [ 06/16/95 3:06 PM ]
|
|---|
| 2 | ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
|
|---|
| 3 | SET ;;Set line item issue information
|
|---|
| 4 | ;; input: RMPFX,RMPFMD,RMPFTYP,PT,CK
|
|---|
| 5 | ;;output: None
|
|---|
| 6 | G PRIOR:CK=1
|
|---|
| 7 | W !!,"Issue item number ",PT," ? YES// " D READ
|
|---|
| 8 | G SETE:$D(RMPFOUT)!$D(RMPFQUT)
|
|---|
| 9 | I Y=""!("Yy"[$E(Y,1)) S (DA,RMPFY)=RMPFMD(PT) G PRIOR
|
|---|
| 10 | K RMPFY Q
|
|---|
| 11 | PRIOR D PRIOR^RMPFET61
|
|---|
| 12 | S X="NOW",%DT="T" D ^%DT S TD=Y
|
|---|
| 13 | S S0=^RMPF(791810,RMPFX,101,RMPFY,0)
|
|---|
| 14 | S AP=$P(S0,U,20) I 'AP S RMPFLA="I" G S1
|
|---|
| 15 | S RMPFLA=$P(S0,U,19) I RMPFLA="" S RMPFLA="I" G S1
|
|---|
| 16 | S RMPFLA=$S(RMPFLA="O":"I",RMPFLA'["I":RMPFLA_"I",1:"I")
|
|---|
| 17 | S1 W !! S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=RMPFY
|
|---|
| 18 | S DR=$S($D(^RMPF(791810.1,5,1)):^RMPF(791810.1,5,1),1:"")
|
|---|
| 19 | S DR=$S(DR'="":DR_";10.01",1:10.01)
|
|---|
| 20 | D ^DIE S S0=^RMPF(791810,RMPFX,101,RMPFY,0)
|
|---|
| 21 | I $P(S0,U,5)="" W $C(7),!!,"*** SERIAL NUMBER REQUIRED ***" G SETE
|
|---|
| 22 | I $P(S0,U,2)="" W $C(7),!!,"*** BATTERY REQUIRED ***" G SETE
|
|---|
| 23 | I $P(S0,U,8)'?7N.E W $C(7),!!,"*** VALID ISSUE DATE REQUIRED ***" G SETE
|
|---|
| 24 | D SUB S DIE="^RMPF(791810,"_RMPFX_",101,",DA=RMPFY,DA(1)=RMPFX
|
|---|
| 25 | S DR=".17////"_TD_";.19////"_RMPFLA_";.2////1" D ^DIE
|
|---|
| 26 | K:$D(PT) RMPFMD(PT) D ^RMPFET61 K RMPFSTR0,RMPFSTR2,RMPFSTR3
|
|---|
| 27 | S DIE="^RMPF(791810,",DA=RMPFX,DR=10.01 D ^DIE
|
|---|
| 28 | SETE K X,Y,Z,TD,AP,LA,DIE,D,D0,DI,DIC,DQ,DA,DR,RMPFLA,RMPFY,S0,RD,%,%T Q
|
|---|
| 29 | SUB ;;Check for delay in hearing aid issue
|
|---|
| 30 | ;; input: RMPFX,RMPFY,S0
|
|---|
| 31 | ;;output: None
|
|---|
| 32 | S RD=$P($G(^RMPF(791810,RMPFX,10)),U,4) Q:'RD
|
|---|
| 33 | S X=$P(S0,U,8),Z=40 G SUBE:'X D PASTWKDY^RMPFET0
|
|---|
| 34 | G SUBE:RD'<Y S DR=90.14,DIE="^RMPF(791810,"_RMPFX_",101,",DA=RMPFY,DA(1)=RMPFX D ^DIE
|
|---|
| 35 | S Y=$P(^RMPF(791810,RMPFX,101,RMPFY,90),U,14)
|
|---|
| 36 | I Y,$D(^RMPF(791810.6,Y,0)) S X=$P(^(0),U,1) G SUBE:X'="OTHER"
|
|---|
| 37 | I Y S DR=90.15 D ^DIE G SUBE:$P(^RMPF(791810,RMPFX,101,RMPFY,90),U,15)'=""
|
|---|
| 38 | W $C(7),!!,"*** A REASON FOR DELAY MUST BE ENTERED ***" K RD
|
|---|
| 39 | SUBE G SUB:'$D(RD) K X,Y,Z,RD,DIE,DR,DA,D0,DQ,DI,DIC,%T,%Y,D,DIZ,DISYS,% Q
|
|---|
| 40 | READ K RMPFOUT,RMPFQUT
|
|---|
| 41 | R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
|
|---|
| 42 | I Y?1"^".E S (RMPFOUT,Y)="" Q
|
|---|
| 43 | S:Y?1"?".E (RMPFQUT,Y)=""
|
|---|
| 44 | Q
|
|---|
| 45 | AUTH ;;Check user for authorization to certify or issue
|
|---|
| 46 | ;; input: NB
|
|---|
| 47 | ;;output: RMPFOUT
|
|---|
| 48 | S X=$P(RMPFSYS,U,NB) G AUTHE:'X
|
|---|
| 49 | I X=1,$D(^RMPF(791813,RMPFSTAN,101,DUZ,0)) G AUTHE
|
|---|
| 50 | I $D(^XUSEC("RMPF SUPERVISOR",DUZ)) G AUTHE
|
|---|
| 51 | W $C(7),!!,"*** YOU HAVE NOT BEEN AUTHORIZED TO ",$S(NB=11:"CERTIFY ORDERS",1:"ISSUE CUSTOM AIDS")," ***" S RMPFOUT=""
|
|---|
| 52 | AUTHE K X Q
|
|---|
| 53 | IU ;;Check to see if user is an audiologist
|
|---|
| 54 | Q:'$P(RMPFSYS,U,12)
|
|---|
| 55 | I $P(RMPFSYS,U,12)=1,$D(^RMPF(791813,RMPFSTAN,101,+Y,0)) G IUE
|
|---|
| 56 | I $P(RMPFSYS,U,12)=2,$D(^XUSEC("RMPF SUPERVISOR",+Y)) G IUE
|
|---|
| 57 | W $C(7),!!,"*** ISSUING USER MUST BE AN AUDIOLOGIST - SEE YOUR ADPAC ***" K X,Y
|
|---|
| 58 | IUE Q
|
|---|
| 59 | STOCK ;;Check for issue delay in stock hearing aids
|
|---|
| 60 | ;; input: RMPFX,RMPFY
|
|---|
| 61 | ;;output: None
|
|---|
| 62 | N DQ,DP,DC,DI,DL
|
|---|
| 63 | S S0=^RMPF(791810,RMPFX,101,RMPFY,0) D SUB
|
|---|
| 64 | S X=$P(^RMPF(791810,RMPFX,0),U,8),DA=RMPFY,DA(1)=RMPFX
|
|---|
| 65 | S DIE="^RMPF(791810,"_RMPFX_",101,",DR="90.12////"_X D ^DIE
|
|---|
| 66 | K DIE,DA,DR,DI,D0,D,DIC,DQ,X,S0 Q
|
|---|
