source: FOIAVistA/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFDD.m@ 1593

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

initial load of FOIAVistA 6/30/08 version

File size: 2.9 KB
Line 
1RMPFDD ;DDC/KAW-PATIENT INFORMATION DISPLAY; [ 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)
5 W @IOF,!,"PATIENT INFORMATION DISPLAY",!!
6PAT S DIC=2,DIC(0)="AEQM" D ^DIC G END:Y=-1 S DFN=+Y
7CON D DISP,CONT G END:$D(RMPFOUT),CON:$D(RMPFQUT),RMPFSET:Y=""
8 D QUE:"Pp"[Y G CON:'$D(ZTSK),RMPFSET
9END K ZTSK,DFN,RMPFE,RMPFTE,RMPFOUT,RMPFQUT,DIC,X,I,A,J,Y,%,%Y,%XX,%YY,POP
10 Q
11DISP ;; input: DFN
12 ;;output: RMPFE,RMPFTE
13 Q:'$D(DFN) D ^RMPFDD2,HEAD
14 W:RMPFVET="N" $C(7),!?23,"*** PATIENT IS NOT A VETERAN ***",!
15 I RMPFDOD'="" W $C(7),!?26,"*** PATIENT IS DECEASED ***"
16 W !?6,"Name: ",RMPFNAM,?49,"SSN: ",RMPFSSN
17 W !?7,"DOB: ",RMPFDOB
18 I $D(RMPFCL),RMPFCL'="" W ?45,"Claim #: ",$J(RMPFCL,11)
19 I RMPFDOD'="" W !?7,"DOD: ",RMPFDOD
20 W !!?3,"Address: " G ELG0:'$D(RMPFA(1)) W RMPFA(1) K RMPFT
21 I RMPFTSD=""&(RMPFTED="") K RMPFTSD,RMPFTED
22 I $D(RMPFTSD) W ?42,"Start Date: ",RMPFTSD
23 F I=2:1 Q:'$D(RMPFA(I)) W !?12,$S($D(RMPFA(I)):RMPFA(I),1:"") I $D(RMPFTED) W ?44,"End Date: ",RMPFTED K RMPFTED
24 W !?5,"Phone: ",RMPFONE I $D(RMPFTED) W ?44,"End Date: ",RMPFTED
25ELG0 W ! F I=1:1:80 W "-"
26 W !!?5,"*** DHCP PATIENT FILE DETERMINATION OF ELIGIBILITY FOR ROES ORDERS ***"
27 G ELG1:'$D(RMPFF) W !!?1,"Veteran Eligibilities: " S (X,C)=0
28 F II=1:1 S X=$O(RMPFF(X)) Q:'X W:II>1 ! W ?24,RMPFF(X) W:II=1&$D(RMPFELS) ?57,$J(RMPFELS,23) W:II=2&$D(RMPFELGD) ?68,$J(RMPFELGD,12)
29 I I=2 W:$D(RMPFELGD) !?68,$J(RMPFELGD,12)
30ELG1 D ^RMPFDD1
31 I $D(RMPFF(1)),RMPFF(1)["ALLIED VETERAN" W $C(7),!!?7,"*** An Allied Veteran Agreement must be on file at the DDC. ***"
32 I $D(RMPFF(1)),RMPFF(1)="AID & ATTENDANCE"!(RMPFF(1)="HOUSEBOUND") W $C(7),!!,"*** This eligibility is subject to change. Be sure verification is recent. ***"
33 I IOST?1"P-".E W @IOF
34 D:$D(IO("S")) ^%ZISC
35QUIT K RMPFVET,RMPFDOD,RMPFCL,RMPFTSD,RMPFTED,RMPFELG,RMPFELGD,RMPFELP
36 K RMPFDOB,RMPFELS,RMPFNAM,RMPFSSN,RMPFELD,RMPFA,RMPFL,RMPFT,RMPFF
37 K RMPFONE,S0,S1,S2,S6,ST,II,C,I,N,P,S,T K X,Y,Z Q
38CONT F I=1:1 Q:$Y>22 W !
39 W !,"Enter <RETURN> to continue or <P>rint: " D READ
40 I $D(RMPFQUT) D MSG G CONT
41 Q:Y="" S Y=$E(Y,1) I "Pp"'[Y G CONT
42 Q
43QUE W ! S %ZIS="NPQ" D ^%ZIS G END:POP
44 I IO=IO(0),'$D(IO("S")) K ZTSK Q
45 I $D(IO("S")) S %ZIS="",IOP=ION D ^%ZIS G DISP^RMPFDD
46 S ZTRTN="DISP^RMPFDD",ZTDESC="PATIENT INFORMATION",ZTIO=ION
47 S ZTSAVE("RMPF*")="",ZTSAVE("DFN")="" D ^%ZTLOAD
48 D HOME^%ZIS W:$D(ZTSK) !!,"*** Request Queued ***" H 2
49 K %T,POP Q
50HEAD W:'$D(ZTSK) @IOF
51 W !?20,"REMOTE ORDER/ENTRY PATIENT INFORMATION"
52 W !,"Station: ",RMPFSTAP,?68,RMPFDAT,!
53 F I=1:1:80 W "-"
54 Q
55READ K RMPFOUT,RMPFQUT
56 R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
57 I Y?1"^".E S (RMPFOUT,Y)="" Q
58 S:Y?1"?".E (RMPFQUT,Y)=""
59 Q
60MSG W !!,"Enter <P> to print the screen"
61 W !?6,"<RETURN> to continue.",!
62 Q
Note: See TracBrowser for help on using the repository browser.