source: WorldVistAEHR/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFEI.m@ 1789

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

initial load of WorldVistAEHR

File size: 2.0 KB
Line 
1RMPFEI ;DDC/KAW-ISSUE CUSTOM HEARING AIDS [ 06/16/95 3:06 PM ]
2 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
3RMPFSET I '$D(RMPFMENU) D MENU^RMPFUTL I '$D(RMPFMENU) W !!,$C(7),"*** A MENU SELECTION MUST BE MADE ***" Q ;;RMPFMENU must be defined
4 I '$D(RMPFSTAN)!'$D(RMPFDAT)!'$D(RMPFSYS) D ^RMPFUTL Q:'$D(RMPFSTAN)!'$D(RMPFDAT)!'$D(RMPFSYS)
5A0 W @IOF,!,"ISSUE CUSTOM HEARING AIDS"
6A1 W !!,"Select Order by Patient Name or Purchase Order Number: "
7 D READ G END:$D(RMPFOUT)
8A11 I $D(RMPFQUT) W !!,"Enter the name of the patient or the Purchase Order Number of the order" G A1
9 G END:Y="",PO:Y?1"G"5N1"-".E S DIC="^DPT(",DIC(0)="EQM"
10 S X=Y D ^DIC G A0:Y=-1 S DFN=+Y,(X,CX,RMPFX)=0
11 F S RMPFX=$O(^RMPF(791810,"C",DFN,RMPFX)) Q:'RMPFX D
12 .D ARRAY^RMPFDT2 S Y=0
13 .F S Y=$O(RMPFO(Y)) Q:'Y I RMPFO(Y)=5,$P($G(^RMPF(791810,RMPFX,101,Y,90)),U,9) S CX=CX+1,X=RMPFX Q
14 I CX=0 D NONE,CONT^RMPFET G END:$D(RMPFOUT),A0
15 I CX=1 S RMPFX=X G SET
16 S RMPFP(5)="",(RMPFORD,RMPFTP)="P" D ^RMPFDS1
17 K RMPFX D SEL^RMPFDX G END:$D(RMPFOUT),A0:'$D(RMPFX)
18 D ARRAY^RMPFDT2 S Y=0 F S Y=$O(RMPFO(Y)) Q:'Y I RMPFO(Y)=5,$P($G(^RMPF(791810,RMPFX,101,Y,90)),U,9) Q
19 I 'Y D NONE,CONT^RMPFET G END:$D(RMPFOUT),A0
20 G SET
21PO S X=Y,DIC="^RMPF(791810,",DIC(0)="EQM"
22 S DIC("S")="I $P(^(0),U,3)=5" D ^DIC K DIC G A0:Y=-1 S RMPFX=+Y
23SET S S0=^RMPF(791810,RMPFX,0),DFN=$P(S0,U,4)
24 S RMPFTP="P",RMPFTYP=$P(S0,U,2)
25 I RMPFTYP,$D(^RMPF(791810.1,RMPFTYP,0)) S RMPFHAT=$P(^(0),U,2)
26DISP D ^RMPFET7 G END:$D(RMPFOUT) D ^RMPFET2 G END:$D(RMPFOUT)
27 D ARRAY^RMPFDT2 S X=0 F S X=$O(^RMPF(791810,RMPFX,101,X)) Q:'X I $D(^(X,0)),$P(^(0),U,20),$P(^(0),U,19)["I" D APPROV1^RMPFEA2 Q
28 G END:$D(RMPFOUT),A0
29END K %,%Y,DFN,DIC,DISYS,I,RMPFHAT,RMPFO,RMPFST,RMPFTYP,RMPFOUT,RMPFCX
30 K RMPFORD,RMPFP,RMPFS,RMPFX,%Y,%Y1,CT,RMPFQUT,RMPFTP,S0,X,Y Q
31CONT F Q:$Y>21 W !
32 W !,"Type <RETURN> to continue." D READ Q
33NONE W !!,"*** THERE ARE NO CERTIFIED LINE ITEMS TO BE ISSUED ***" Q
34READ K RMPFOUT,RMPFQUT
35 R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
36 I Y?1"^".E S (RMPFOUT,Y)="" Q
37 S:Y?1"?".E (RMPFQUT,Y)=""
38 Q
Note: See TracBrowser for help on using the repository browser.