RMPFDD1 ;DDC/KAW-DETERMINE PATIENT'S DDC ELIGIBILITY; [ 06/16/95 3:06 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
;;input: RMPFVET,RMPFDOD,RMPFELS,RMPFF (opt.)
;;output: RMPFE,RMPFTE
ELIG S RMPFE="I",RMPFMSG="VALID ELIGIBILITY NOT IN DHCP PATIENT FILE"
I RMPFVET="N" S RMPFMSG="PATIENT IS NOT A VETERAN"
I RMPFDOD'="" S RMPFMSG="PATIENT IS DECEASED"
I $D(RMPFELS),RMPFELS'?1"V".E S RMPFMSG="ELIGIBILITY NOT VERIFIED" G ELGE
I RMPFVET="N" S X=0 F I=1:1 S X=$O(RMPFF(X)) Q:'X I RMPFF(X)["ALLIED"!(RMPFF(X)["OTHER GOV") S RMPFMSG=RMPFF(X),RMPFE="E" G ELGE
I $D(RMPFF(1)) S RMPFMSG=RMPFF(1),RMPFE="E"
ELGE S:RMPFE="I" RMPFTE=""
W !!?23,"Patient is: ",$S(RMPFE="E":"ELIGIBLE",1:"ELIGIBILITY CANNOT BE DETERMINED")
W ! W:RMPFE="E" ?2 W "Priority Reason for ",$S(RMPFE="E":"E",1:"Ine"),"ligibility: ",$E(RMPFMSG,1,44)
END K RMPFMSG,X,I Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFDD1 868 printed Dec 13, 2024@02:35:42 Page 2
RMPFDD1 ;DDC/KAW-DETERMINE PATIENT'S DDC ELIGIBILITY; [ 06/16/95 3:06 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
+2 ;;input: RMPFVET,RMPFDOD,RMPFELS,RMPFF (opt.)
+3 ;;output: RMPFE,RMPFTE
ELIG SET RMPFE="I"
SET RMPFMSG="VALID ELIGIBILITY NOT IN DHCP PATIENT FILE"
+1 IF RMPFVET="N"
SET RMPFMSG="PATIENT IS NOT A VETERAN"
+2 IF RMPFDOD'=""
SET RMPFMSG="PATIENT IS DECEASED"
+3 IF $DATA(RMPFELS)
IF RMPFELS'?1"V".E
SET RMPFMSG="ELIGIBILITY NOT VERIFIED"
GOTO ELGE
+4 IF RMPFVET="N"
SET X=0
FOR I=1:1
SET X=$ORDER(RMPFF(X))
if 'X
QUIT
IF RMPFF(X)["ALLIED"!(RMPFF(X)["OTHER GOV")
SET RMPFMSG=RMPFF(X)
SET RMPFE="E"
GOTO ELGE
+5 IF $DATA(RMPFF(1))
SET RMPFMSG=RMPFF(1)
SET RMPFE="E"
ELGE if RMPFE="I"
SET RMPFTE=""
+1 WRITE !!?23,"Patient is: ",$SELECT(RMPFE="E":"ELIGIBLE",1:"ELIGIBILITY CANNOT BE DETERMINED")
+2 WRITE !
if RMPFE="E"
WRITE ?2
WRITE "Priority Reason for ",$SELECT(RMPFE="E":"E",1:"Ine"),"ligibility: ",$EXTRACT(RMPFMSG,1,44)
END KILL RMPFMSG,X,I
QUIT
