63 lines
2.9 KiB
Mathematica
63 lines
2.9 KiB
Mathematica
|
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
|