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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFDD 3052 printed Dec 13, 2024@02:35:41 Page 2
RMPFDD ;DDC/KAW-PATIENT INFORMATION DISPLAY; [ 06/16/95 3:06 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
RMPFSET ;;RMPFMENU must be defined
IF '$DATA(RMPFMENU)
DO MENU^RMPFUTL
IF '$DATA(RMPFMENU)
WRITE !!,$CHAR(7),"*** A MENU SELECTION MUST BE MADE ***"
QUIT
+1 IF '$DATA(RMPFSTAN)!'$DATA(RMPFDAT)!'$DATA(RMPFSYS)
DO ^RMPFUTL
if '$DATA(RMPFSTAN)!'$DATA(RMPFDAT)!'$DATA(RMPFSYS)
QUIT
+2 WRITE @IOF,!,"PATIENT INFORMATION DISPLAY",!!
PAT SET DIC=2
SET DIC(0)="AEQM"
DO ^DIC
if Y=-1
GOTO END
SET DFN=+Y
CON DO DISP
DO CONT
if $DATA(RMPFOUT)
GOTO END
if $DATA(RMPFQUT)
GOTO CON
if Y=""
GOTO RMPFSET
+1 if "Pp"[Y
DO QUE
if '$DATA(ZTSK)
GOTO CON
GOTO RMPFSET
END KILL ZTSK,DFN,RMPFE,RMPFTE,RMPFOUT,RMPFQUT,DIC,X,I,A,J,Y,%,%Y,%XX,%YY,POP
+1 QUIT
DISP ;; input: DFN
+1 ;;output: RMPFE,RMPFTE
+2 if '$DATA(DFN)
QUIT
DO ^RMPFDD2
DO HEAD
+3 if RMPFVET="N"
WRITE $CHAR(7),!?23,"*** PATIENT IS NOT A VETERAN ***",!
+4 IF RMPFDOD'=""
WRITE $CHAR(7),!?26,"*** PATIENT IS DECEASED ***"
+5 WRITE !?6,"Name: ",RMPFNAM,?49,"SSN: ",RMPFSSN
+6 WRITE !?7,"DOB: ",RMPFDOB
+7 IF $DATA(RMPFCL)
IF RMPFCL'=""
WRITE ?45,"Claim #: ",$JUSTIFY(RMPFCL,11)
+8 IF RMPFDOD'=""
WRITE !?7,"DOD: ",RMPFDOD
+9 WRITE !!?3,"Address: "
if '$DATA(RMPFA(1))
GOTO ELG0
WRITE RMPFA(1)
KILL RMPFT
+10 IF RMPFTSD=""&(RMPFTED="")
KILL RMPFTSD,RMPFTED
+11 IF $DATA(RMPFTSD)
WRITE ?42,"Start Date: ",RMPFTSD
+12 FOR I=2:1
if '$DATA(RMPFA(I))
QUIT
WRITE !?12,$SELECT($DATA(RMPFA(I)):RMPFA(I),1:"")
IF $DATA(RMPFTED)
WRITE ?44,"End Date: ",RMPFTED
KILL RMPFTED
+13 WRITE !?5,"Phone: ",RMPFONE
IF $DATA(RMPFTED)
WRITE ?44,"End Date: ",RMPFTED
ELG0 WRITE !
FOR I=1:1:80
WRITE "-"
+1 WRITE !!?5,"*** DHCP PATIENT FILE DETERMINATION OF ELIGIBILITY FOR ROES ORDERS ***"
+2 if '$DATA(RMPFF)
GOTO ELG1
WRITE !!?1,"Veteran Eligibilities: "
SET (X,C)=0
+3 FOR II=1:1
SET X=$ORDER(RMPFF(X))
if 'X
QUIT
if II>1
WRITE !
WRITE ?24,RMPFF(X)
if II=1&$DATA(RMPFELS)
WRITE ?57,$JUSTIFY(RMPFELS,23)
if II=2&$DATA(RMPFELGD)
WRITE ?68,$JUSTIFY(RMPFELGD,12)
+4 IF I=2
if $DATA(RMPFELGD)
WRITE !?68,$JUSTIFY(RMPFELGD,12)
ELG1 DO ^RMPFDD1
+1 IF $DATA(RMPFF(1))
IF RMPFF(1)["ALLIED VETERAN"
WRITE $CHAR(7),!!?7,"*** An Allied Veteran Agreement must be on file at the DDC. ***"
+2 IF $DATA(RMPFF(1))
IF RMPFF(1)="AID & ATTENDANCE"!(RMPFF(1)="HOUSEBOUND")
WRITE $CHAR(7),!!,"*** This eligibility is subject to change. Be sure verification is recent. ***"
+3 IF IOST?1"P-".E
WRITE @IOF
+4 if $DATA(IO("S"))
DO ^%ZISC
QUIT KILL RMPFVET,RMPFDOD,RMPFCL,RMPFTSD,RMPFTED,RMPFELG,RMPFELGD,RMPFELP
+1 KILL RMPFDOB,RMPFELS,RMPFNAM,RMPFSSN,RMPFELD,RMPFA,RMPFL,RMPFT,RMPFF
+2 KILL RMPFONE,S0,S1,S2,S6,ST,II,C,I,N,P,S,T
KILL X,Y,Z
QUIT
CONT FOR I=1:1
if $Y>22
QUIT
WRITE !
+1 WRITE !,"Enter <RETURN> to continue or <P>rint: "
DO READ
+2 IF $DATA(RMPFQUT)
DO MSG
GOTO CONT
+3 if Y=""
QUIT
SET Y=$EXTRACT(Y,1)
IF "Pp"'[Y
GOTO CONT
+4 QUIT
QUE WRITE !
SET %ZIS="NPQ"
DO ^%ZIS
if POP
GOTO END
+1 IF IO=IO(0)
IF '$DATA(IO("S"))
KILL ZTSK
QUIT
+2 IF $DATA(IO("S"))
SET %ZIS=""
SET IOP=ION
DO ^%ZIS
GOTO DISP^RMPFDD
+3 SET ZTRTN="DISP^RMPFDD"
SET ZTDESC="PATIENT INFORMATION"
SET ZTIO=ION
+4 SET ZTSAVE("RMPF*")=""
SET ZTSAVE("DFN")=""
DO ^%ZTLOAD
+5 DO HOME^%ZIS
if $DATA(ZTSK)
WRITE !!,"*** Request Queued ***"
HANG 2
+6 KILL %T,POP
QUIT
HEAD if '$DATA(ZTSK)
WRITE @IOF
+1 WRITE !?20,"REMOTE ORDER/ENTRY PATIENT INFORMATION"
+2 WRITE !,"Station: ",RMPFSTAP,?68,RMPFDAT,!
+3 FOR I=1:1:80
WRITE "-"
+4 QUIT
READ KILL RMPFOUT,RMPFQUT
+1 READ Y:DTIME
IF '$TEST
WRITE $CHAR(7)
READ Y:5
if Y="."
GOTO READ
if '$TEST
SET Y=U
+2 IF Y?1"^".E
SET (RMPFOUT,Y)=""
QUIT
+3 if Y?1"?".E
SET (RMPFQUT,Y)=""
+4 QUIT
MSG WRITE !!,"Enter <P> to print the screen"
+1 WRITE !?6,"<RETURN> to continue.",!
+2 QUIT
