source: FOIAVistA/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFDS1.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1RMPFDS1 ;DDC/KAW-LIST ORDERS BY PATIENT OR STATUS; [ 03/12/98 7:45 AM ]
2 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**8,10,16**;MAY 30, 1995
3 ;;Reference to ^VA(200) supported by DBIA #10060
4 ;; input: RMPFTP,RMPFORD,DFN (if RMPFORD="P")
5 ;;output: RMPFS,RMPFCX,RMPFO
6 I $D(DFN),DFN D PAT^RMPFUTL
7 D @("HEAD"_RMPFORD) S (RMPF,RMPFCX)=0
8 I RMPFORD="S" F I=1:1 S RMPF=$O(^RMPF(791810,"AD",RMPF)) Q:'RMPF G END:$D(RMPFOUT) S RMPFX=0 F J=1:1 S RMPFX=$O(^RMPF(791810,"AD",RMPF,RMPFX)) Q:'RMPFX D SUB G END:$D(RMPFOUT),END:'$D(RMPFX)
9 I RMPFORD="P" F I=1:1 S RMPF=$O(^RMPF(791810,"AE",DFN,RMPF)) Q:RMPF="" G END:$D(RMPFOUT) S RMPFX=0 F J=1:1 S RMPFX=$O(^RMPF(791810,"AE",DFN,RMPF,RMPFX)) Q:'RMPFX D SUB G END:$D(RMPFOUT),END:'$D(RMPFX)
10 G END:$D(RMPFOUT)
11 W:RMPFCX<1 !!,"NO EXISTING ORDERS"
12 W:RMPFCX !!,"Total Orders: ",RMPFCX
13 W:IOST?1"P-".E @IOF
14 D:$D(IO("S")) ^%ZISC
15END K RMPFNAM,SSN,RMPFSSN,RMPFDOB,DOB,Y,RMPF,RMPFX,RMPFST,RMPFMGG,RMPFSD
16 K I,J,T,RMPFDOD,OO Q
17READ K RMPFOUT,RMPFQUT
18 R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
19 I Y?1"^" S (RMPFOUT,Y)="" Q
20 S:Y?1"?".E (RMPFQUT,Y)=""
21 Q
22SUB ;;input: RMPFX,RMPFTP,RMPFORD,RMPFCX,RMPFNAM,RMPFSSN,RMPFDOB,RMPFP (opt), RMPFOO (opt.)
23 ;;output: RMPFCX,RMPFS
24 Q:RMPFX=""
25 Q:'$D(^RMPF(791810,RMPFX,0)) S SX=^(0)
26 S X=$P(SX,U,15) S:X="" X=1 S X=$P(^RMPF(791810.5,X,0),U,2) S:X="" X=1 Q:X'=RMPFMENU
27 Q:'$D(^RMPF(791810,RMPFX,"STA")) Q:$P(RMPFSTAP," - ",1)'=$P($P(^("STA"),U,1)," - ",1)
28 I $D(RMPFOO) D I OO,OO'=RMPFOO Q
29 .S OO=$P(SX,U,8),X=0 D ARRAY^RMPFDT2
30 .F S X=$O(RMPFO(X)) Q:'X I $D(^RMPF(791810,RMPFX,101,X,90)),$P(^(90),U,12) S OO=$P(^(90),U,12)
31 S Y=$P($P(SX,U,1),".",1),RMPFTDP=$E(Y,4,5)_"-"_$E(Y,6,7)_"-"_($E(Y,1,3)+1700)
32 S Y=$P($P(SX,U,6),".",1),RMPFSD=$E(Y,4,5)_"-"_$E(Y,6,7)_"-"_($E(Y,1,3)+1700)
33 S RMPFTYP="",X=$P(SX,U,2)
34 G SUBE:'X,SUBE:'$D(^RMPF(791810.1,X,0)) S SS=^(0)
35 S RMPFTYP=$S(RMPFTP'="S":$P(SS,U,8),1:$P(SS,U,1)),T=$P(SS,U,3)
36 I RMPFTP'="B" G SUBE:T'=RMPFTP
37 G SUBE:RMPFTYP=""
38 S RMPFST="",X=$P(SX,U,3) I X,$D(^RMPF(791810.2,X,0)) S RMPFST=$P(^(0),U,4)
39 G SUBE:X="" I RMPFORD="S",$D(RMPFP)'=1 G SUBE:'$D(RMPFP(X))
40 I RMPFORD="P",$D(RMPFP)=10 G SUBE:'$D(RMPFP(X))
41 I RMPFORD="S" S RMPFNAM="N/A",RMPFSSN="",DFN=$P(SX,U,4) I RMPFTP'="S",DFN D PAT^RMPFUTL
42 S RMPFAD=$P(SX,U,8),RMPFADP="" I RMPFAD,$D(^VA(200,RMPFAD,0)) S RMPFADP=$P(^(0),U,1)
43 I RMPFMENU=0 D ARRAY^RMPFDT2 S X=0 F S X=$O(RMPFO(X)) Q:'X I $D(^RMPF(791810,RMPFX,101,X,90)),$P(^(90),U,12) S Y=$P(^(90),U,12) I Y,$D(^VA(200,Y,0)) S RMPFADP=$P(^(0),U,1)
44 S CT=0,RMPFCX=RMPFCX+1,RMPFS(RMPFCX)=RMPFX
45 I IOST?1"C-".E,$Y>20 D CONT S:'$D(RMPFX) RMPFOUT="" G SUBE:$D(RMPFOUT) D @("HEAD"_RMPFORD)
46 I IOST?1"P-".E,$Y>(IOSL-5) D @("HEAD"_RMPFORD)
47 S RMPFMGG="",X=0 F I=1:1 S X=$O(^RMPF(791810,RMPFX,201,X)) Q:'X S Y=0 F J=1:1 S Y=$O(^RMPF(791810,RMPFX,201,X,101,Y)) Q:'Y I $D(^(Y,0)),'$P(^(0),U,6) S RMPFMGG="***" Q
48 D @("WRITE"_RMPFORD)
49SUBE K S0,SS,SX,Y,RMPFTDP,RMPFTYP,X,TT,RMPFAD,RMPFADP,CT,RMPFMGG
50 K RMPFO,RMPFSD,RMPFST,T Q
51HEADP W @IOF,!?24,"REMOTE ORDER/ENTRY PATIENT ORDERS"
52 W !,"Station: ",RMPFSTAP,?68,RMPFDAT
53 W !,"Patient: ",$E(RMPFNAM,1,25),?40,"SSN: ",RMPFSSN,?62,"DOB: ",RMPFDOB
54 W !!?6,"Status",?46,"Order"
55 W !?1,"#",?7,"Date",?15,"Status",?23,"Type",?30,"Ord" W $S(RMPFMENU=0:"/Iss",1:"ered") W " By",?46,"Date",?54,"MSG",?65,"Item(s)"
56 W !,"---",?4,"----------",?15,"------",?22,"------",?29,"-------------",?43,"----------",?54,"---",?58,"----------------------"
57 Q
58WRITEP W !,$J(RMPFCX,2),". ",RMPFSD,?15,RMPFST,?22,RMPFTYP,?29,$E(RMPFADP,1,13),?43,RMPFTDP,?54,RMPFMGG D ARRAY^RMPFDT2 S X=0
59W1 S X=$O(RMPFO(X)) G W2:'X
60 I $D(^RMPF(791810,RMPFX,101,X,0)) S RMPFIT=$P(^(0),U,1) D
61 .Q:'RMPFIT Q:'$D(^RMPF(791811,RMPFIT,0)) S S0=^(0)
62 .I RMPFIT=1 S RMPFITP=$P($G(^RMPF(791810,RMPFX,101,X,2)),U,2)
63 .E S RMPFITP=$E($P(S0,U,1),1,22)
64 .W:CT ! W ?58,RMPFITP S CT=CT+1
65 G W1
66W2 K RMPFIT,RMPFITP Q
67HEADS W @IOF,!?28,"REMOTE ORDER/ENTRY ORDERS"
68HEADS1 W !,"Station: ",RMPFSTAP,?68,RMPFDAT
69 W !!?5,"Status",?68,"Order"
70 W !,?1,"#",?6,"Date",?15,"Status" W:RMPFTP="S" ?35,"Type"
71 W:RMPFTP'="S" ?23,"Type",?36,"Patient" W ?53,"Ord" W $S(RMPFMENU=0:"/Iss",1:"ered") W " By",?69,"Date",?77,"MSG"
72 W !,"---",?4,"----------",?15,"------"
73 I RMPFTP'="S" W ?22,"------",?29,"----------------------"
74 E W ?22,"------------------------------"
75 W ?53,"-----------",?66,"----------",?77,"---"
76 Q
77WRITES W !,$J(RMPFCX,2),". ",RMPFSD,?15,RMPFST
78 W ?22,$E(RMPFTYP,1,$S(RMPFTP'="S":14,1:28))
79 W:RMPFTP'="S" ?29,$E(RMPFNAM,1,16) W:RMPFSSN'="" ?46,"-",$E(RMPFSSN,8,11)
80 W ?53,$E(RMPFADP,1,11),?66,RMPFTDP,?77,RMPFMGG
81 Q
82CONT F I=1:1 Q:$Y>20 W !
83 W !,"Type <RETURN> to continue, <P>rint or <^> to exit: " D READ
84 Q:$D(RMPFOUT) G CONT:$D(RMPFQUT)
85 Q:Y="" D QUE^RMPFDS2:"Pp"[Y
86 Q
Note: See TracBrowser for help on using the repository browser.