source: FOIAVistA/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFDT7.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 4.1 KB
Line 
1RMPFDT7 ;DDC/KAW-DISPLAY ADJUSTMENTS [ 03/12/98 7:46 AM ]
2 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**10**;JUN 16, 1995
3 ;; input: RMPFX,DFN
4 ;;output:
5 Q:'$D(DFN) D PAT^RMPFUTL,HEAD S (F1,RMPFTOT)=0
6 S S0=^RMPF(791810,RMPFX,0),RMPFTYP=$P(^(0),U,2),RMPFHAT=""
7 I RMPFTYP,$D(^RMPF(791810.1,RMPFTYP,0)) S RMPFHAT=$P(^(0),U,2)
8A1 S F1=$O(^RMPF(791810,RMPFX,101,"AD",F1)) G EXIT:'F1 S (F2,MT)=0
9A2 S F2=$O(^RMPF(791810,RMPFX,101,"AD",F1,F2)) I 'F2 D WRITE G END:$D(RMPFOUT),A1
10 G A2:'$D(^RMPF(791810,RMPFX,101,F2,0)) S S0=^(0),(TT,CN)=0
11 S (RD,RE,US)="",S9=$G(^RMPF(791810,RMPFX,101,F2,90))
12 I "OC"[$P(S0,U,15) S RD=$P(^RMPF(791810,RMPFX,0),U,9),US=$P(^(0),U,8) G A3
13 G NO:S9="" S US=$P(S9,U,1),RD=$P(S9,U,2)
14A3 I US,$D(^VA(200,US,0)) S US=$E($P(^(0),U,1),1,14)
15 I RD S RD=$E(RD,4,5)_"-"_$E(RD,6,7)_"-"_($E(RD,1,3)+1700)
16 S RE=$P(S9,U,3)
17NO S RMPFIT=$P(S0,U,1),RMPFITP=""
18 I RMPFIT,$D(^RMPF(791811,RMPFIT,0)) S RMPFITP=$P(^(0),U,1)
19 S RMPFTOE=$P(S0,U,15),RMPFTOE=$S(RMPFTOE="D":"DELETED",RMPFTOE="DC":"CHNG-DL",RMPFTOE="OC":"CHNG-OR",1:"ORDER")
20 S RMPFCS=$P(S0,U,14),RMPFLR=$P(S0,U,4) S:RMPFHAT="X" RMPFCS=0
21 I $P(S0,U,15)="C" S RMPFCS=0,CN=1
22 S:$P(S0,U,15)["D" RMPFCS=-RMPFCS
23 S RMPFTOT=RMPFTOT+RMPFCS,MT=MT+RMPFCS,TT=TT+RMPFCS
24 D SUB S (X,CT)=0 F I=1:1 S X=$O(CM(X)) Q:'X S CT=CT+1
25 I $Y+CT>$S(IOST?1"C-".E:20,1:58) D CONT:IOST?1"C-".E Q:$D(RMPFOUT) D HEAD W !,"(cont.)"
26 W !,RD,?12,RMPFTOE
27 W:RMPFHAT'="X" ?21,$E(RMPFITP,1,11)
28 W ?33,CM,?52,$J(TT,7,2),?62,RMPFLR,?66,$E(US,1,14)
29 G A2:'$D(CM)
30 S X=0 F I=1:1 S X=$O(CM(X)) Q:'X S T=$S(CN=0:$P(CM(X),U,4),1:0) W !,$P(CM(X),U,1),?12,$P(CM(X),U,2),?33,$E($P(CM(X),U,3),1,18),?52,$J(T,7,2),?66,$E($P(CM(X),U,5),1,14)
31 I CN=1 D
32 .S S3=$G(^RMPF(791810,RMPFX,101,F2,90))
33 .S X=$P(S3,U,13) I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
34 .S Y=$P(S0,U,17) D DD^%DT S R=$P(S3,U,5)
35 .W !,"*** CANCELED *** by: ",X,?$X+3,"on ",Y
36 .W !?13,"Reason: ",R
37 G A2
38SUB S F3=0 K CM S CM=""
39B1 S F3=$O(^RMPF(791810,RMPFX,101,F2,102,F3)) G BE:'F3
40 G B1:'$D(^RMPF(791810,RMPFX,101,F2,102,F3,0)) S S2=^(0)
41 S C=$P(S2,U,1),T=$P(S2,U,2),P=$P(S2,U,3),L=$P(S2,U,4)
42 I CN=1 S T=0
43 I C,$D(^RMPF(791811.2,C,0)) S C=$P(^(0),U,3)
44 S P=$S(P="A":"ADDED",P="D":"DELETED",1:"ORDER") S:P="DELETED" T=-T
45 S RMPFTOT=RMPFTOT+T,MT=MT+T
46 I P["ORDER"!(RMPFTOE="DELETED")!((RMPFTOE="CHNG-DL")&(P="DELETED")) S CM=$S(CM="":C,1:CM_","_C),TT=TT+T G B1
47 S S=$P(S2,U,5),R=$P(S2,U,6)
48 I S,$D(^VA(200,S,0)) S S=$P(^(0),U,1)
49 I R S R=$E(R,4,5)_"-"_$E(R,6,7)_"-"_($E(R,1,3)+1700)
50 S CM(F3)=R_U_P_U_C_U_T_U_S
51 G B1
52BE K R,P,C,T,S,L Q
53EXIT I $Y>$S(IOST?1"C-".E:20,1:58) D CONT:IOST?1"C-".E G END:$D(RMPFOUT) D HEAD W !,"(cont.)"
54 W ?53,"======",!,"Total Price:",?52,"$",$J(RMPFTOT,6,2)
55 D CONT1:IOST?1"C-".E W:IOST?1"P-".E @IOF
56 D:$D(IO("S")) ^%ZISC
57END K F2,F2,F3,RMPFTOT,MT,S0,S2,S9,RD,RE,US,RMPFIT,RMPFITP,RMPFTOE,RMPFCS
58 K RMPFLR,RMPFNAM,RMPFQUT,RMPFSSN,RMPFDOB,RMPFDOD,RMPFOUT,RMPFQUT,T
59 K S3,%XX,%YY,CT,F1,I,TT,CM,CN,X,Y,R Q
60WRITE I $Y>$S(IOST?1"C-".E:20,1:58) D CONT:IOST?1"C-".E Q:$D(RMPFOUT) D HEAD W !,"cont.)"
61 W !?53,"------",!?52,"$",$J(MT,6,2),! Q
62HEAD W:IOST?1"C-".E @IOF W !?33,"ORDER HISTORY"
63 W !,"Station: ",RMPFSTAP,?68,RMPFDAT
64 W !,"Patient: ",$E(RMPFNAM,1,25),?40,"SSN: ",RMPFSSN,?62,"DOB: ",RMPFDOB
65 W ! F I=1:1:80 W "-"
66 W !,?3,"Order",?12,"Type of",?70,"Order"
67 W !?3,"Date",?13,"Entry",?24,"Model",?36,"Component(s)",?53,"Price",?61,"Ear",?68,"Entered By"
68 W !,"----------",?12,"-------",?21,"-----------",?33,"------------------",?53,"------",?61,"---",?66,"--------------"
69 Q
70READ K RMPFOUT,RMPFQUT
71 R Y:DTIME I '$T W *7 R Y:5 G READ:Y="." S:'$T Y=U
72 I Y?1"^".E S (RMPFOUT,Y)="" Q
73 S:Y?1"?".E (RMPFQUT,Y)=""
74 Q
75CONT D SPACE
76 W !,"Type <RETURN> to continue or <^> to exit: " D READ
77 G CONT:$D(RMPFQUT)
78 Q
79CONT1 D SPACE W !
80 W !,"Type <RETURN> to continue or <P>rint: " D READ
81 Q:$D(RMPFOUT) G CONT1:$D(RMPFQUT) Q:Y="" S Y=$E(Y,1)
82 D QUE:"Pp"[Y Q
83SPACE F Q:$Y>21 W !
84 Q
85QUE W ! S %ZIS="QNP" D ^%ZIS G END:POP
86 I IO=IO(0),'$D(IO("S")) D ^RMPFDT7 G QUEE
87 I $D(IO("S")) S %ZIS="",IOP=ION D ^%ZIS G ^RMPFDT7
88 S ZTRTN="^RMPFDT7",ZTSAVE("RMPF*")="",ZTSAVE("DFN")=""
89 S ZTIO=ION D ^%ZTLOAD
90 D HOME^%ZIS S RMPFOUT=""
91 W:$D(ZTSK) !!,"*** Request Queued ***" H 2
92QUEE K %T,%ZIS,POP,ZTRTN,ZTSAVE,ZTIO,ZTSK Q
Note: See TracBrowser for help on using the repository browser.