RMPFDD1.m

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 ---RMPFDD1   868     printed  Apr 09, 2024@21:38:46                                                                                                                                                                                                      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