RMPFDD ;DDC/KAW-PATIENT INFORMATION DISPLAY; [ 06/16/95   3:06 PM ]
 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
RMPFSET I '$D(RMPFMENU) D MENU^RMPFUTL I '$D(RMPFMENU) W !!,$C(7),"*** A MENU SELECTION MUST BE MADE ***" Q  ;;RMPFMENU must be defined
 I '$D(RMPFSTAN)!'$D(RMPFDAT)!'$D(RMPFSYS) D ^RMPFUTL Q:'$D(RMPFSTAN)!'$D(RMPFDAT)!'$D(RMPFSYS)
 W @IOF,!,"PATIENT INFORMATION DISPLAY",!!
PAT S DIC=2,DIC(0)="AEQM" D ^DIC G END:Y=-1 S DFN=+Y
CON D DISP,CONT G END:$D(RMPFOUT),CON:$D(RMPFQUT),RMPFSET:Y=""
 D QUE:"Pp"[Y G CON:'$D(ZTSK),RMPFSET
END K ZTSK,DFN,RMPFE,RMPFTE,RMPFOUT,RMPFQUT,DIC,X,I,A,J,Y,%,%Y,%XX,%YY,POP
 Q
DISP ;; input: DFN
 ;;output: RMPFE,RMPFTE
 Q:'$D(DFN)  D ^RMPFDD2,HEAD
 W:RMPFVET="N" $C(7),!?23,"*** PATIENT IS NOT A VETERAN ***",!
 I RMPFDOD'="" W $C(7),!?26,"*** PATIENT IS DECEASED ***"
 W !?6,"Name: ",RMPFNAM,?49,"SSN: ",RMPFSSN
 W !?7,"DOB: ",RMPFDOB
 I $D(RMPFCL),RMPFCL'="" W ?45,"Claim #: ",$J(RMPFCL,11)
 I RMPFDOD'="" W !?7,"DOD: ",RMPFDOD
 W !!?3,"Address: " G ELG0:'$D(RMPFA(1)) W RMPFA(1) K RMPFT
 I RMPFTSD=""&(RMPFTED="") K RMPFTSD,RMPFTED
 I $D(RMPFTSD) W ?42,"Start Date: ",RMPFTSD
 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
 W !?5,"Phone: ",RMPFONE I $D(RMPFTED) W ?44,"End Date: ",RMPFTED
ELG0 W ! F I=1:1:80 W "-"
 W !!?5,"*** DHCP PATIENT FILE DETERMINATION OF ELIGIBILITY FOR ROES ORDERS ***"
 G ELG1:'$D(RMPFF) W !!?1,"Veteran Eligibilities: " S (X,C)=0
 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)
 I I=2 W:$D(RMPFELGD) !?68,$J(RMPFELGD,12)
ELG1 D ^RMPFDD1
 I $D(RMPFF(1)),RMPFF(1)["ALLIED VETERAN" W $C(7),!!?7,"*** An Allied Veteran Agreement must be on file at the DDC. ***"
 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. ***"
 I IOST?1"P-".E W @IOF
 D:$D(IO("S")) ^%ZISC
QUIT K RMPFVET,RMPFDOD,RMPFCL,RMPFTSD,RMPFTED,RMPFELG,RMPFELGD,RMPFELP
 K RMPFDOB,RMPFELS,RMPFNAM,RMPFSSN,RMPFELD,RMPFA,RMPFL,RMPFT,RMPFF
 K RMPFONE,S0,S1,S2,S6,ST,II,C,I,N,P,S,T K X,Y,Z Q
CONT F I=1:1 Q:$Y>22  W !
 W !,"Enter <RETURN> to continue or <P>rint: " D READ
 I $D(RMPFQUT) D MSG G CONT
 Q:Y=""  S Y=$E(Y,1) I "Pp"'[Y G CONT
 Q
QUE W ! S %ZIS="NPQ" D ^%ZIS G END:POP
 I IO=IO(0),'$D(IO("S")) K ZTSK Q
 I $D(IO("S")) S %ZIS="",IOP=ION D ^%ZIS G DISP^RMPFDD
 S ZTRTN="DISP^RMPFDD",ZTDESC="PATIENT INFORMATION",ZTIO=ION
 S ZTSAVE("RMPF*")="",ZTSAVE("DFN")="" D ^%ZTLOAD
 D HOME^%ZIS W:$D(ZTSK) !!,"*** Request Queued ***" H 2
 K %T,POP Q
HEAD W:'$D(ZTSK) @IOF
 W !?20,"REMOTE ORDER/ENTRY PATIENT INFORMATION"
 W !,"Station:  ",RMPFSTAP,?68,RMPFDAT,!
 F I=1:1:80 W "-"
 Q
READ K RMPFOUT,RMPFQUT
 R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
 I Y?1"^".E S (RMPFOUT,Y)="" Q
 S:Y?1"?".E (RMPFQUT,Y)=""
 Q
MSG W !!,"Enter <P> to print the screen"
 W !?6,"<RETURN> to continue.",!
 Q