BMCALT ; IHS/PHXAO/TMJ - LIST ALTERNATE RESOURCES ;
;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
;
; This routine lists alternate resources for the selected patient
;
START ;
F D MAIN Q:BMCQ D HDR^BMC
D EOJ
Q
;
MAIN ;
S BMCQ=0
D PATIENT ; get patient being referred
Q:BMCQ
D LIST ; list alternate resourece
Q
;
PATIENT ; GET PATIENT
F D PATIENT2 I BMCQ!($G(BMCDFN)) Q
Q
;
PATIENT2 ; ASK FOR PATIENT UNTIL USER SELECTS OR QUITS
S BMCQ=1
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D DIC^BMCFMC
Q:Y<1
S BMCDFN=+Y,BMCREC("PAT NAME")=$P(^DPT(+Y,0),U)
S BMCQ=0
I $$DOD^AUPNPAT(BMCDFN) D I 'Y K BMCDFN,BMCREC("PAT NAME") Q
. W !!,"This patient is deceased."
. S DIR(0)="YO",DIR("A")="Are you sure you want this patient",DIR("B")="NO" K DA D ^DIR K DIR
. W !
. Q
Q
;
LIST ; LIST ALTERNATE RESOURCES
Q:'$G(BMCDFN)
S BMCRDATE=DT
NEW BMCMSG,BMCI,BMCX
S BMCI=1
S BMCX=$$BEN^AUPNPAT(BMCDFN,"E")
S:BMCX="" BMCX="UNKNOWN"
S BMCMSG(BMCI)="CLASSIFICATION/BENEFICIARY IS: "_BMCX,BMCI=+BMCI+1
S BMCX=$$ELIGSTAT^AUPNPAT(BMCDFN,"E")
S:BMCX="" BMCX="UNKNOWN"
S BMCMSG(BMCI)="ELIGIBILITY STATUS IS: "_BMCX,BMCI=+BMCI+1
NEW BMCELG
S BMCELG=BMCI
I $$MCR^AUPNPAT(BMCDFN,BMCRDATE) S BMCMSG(BMCI)="PATIENT HAS MEDICARE",BMCI=BMCI+1
;I $$MCD^AUPNPAT(BMCDFN,BMCRDATE) S BMCMSG(BMCI)="PATIENT HAS MEDICAID--",BMCI=BMCI+1
S BMCX=$$MCDPN^AUPNPAT(BMCDFN,BMCRDATE,"E")
S:BMCX="" BMCX="UNKNOWN"
I $$MCD^AUPNPAT(BMCDFN,BMCRDATE) S BMCMSG(BMCI)="PATIENT HAS MEDICAID-PLAN NAME: "_BMCX,BMCI=+BMCI+1
;I $$PI^AUPNPAT(BMCDFN,BMCRDATE) S BMCMSG(BMCI)="PATIENT HAS PRIVATE INSURANCE--",BMCI=BMCI+1
S BMCX=$$PIN^AUPNPAT(BMCDFN,BMCRDATE,"E")
S:BMCX="" BMCX="UNKNOWN"
I $$PI^AUPNPAT(BMCDFN,BMCRDATE) S BMCMSG(BMCI)="PATIENT HAS INSURANCE-INSURER: "_BMCX,BMCI=BMCI+1
I BMCELG=BMCI S BMCMSG(BMCI)="NO THIRD PARTY COVERAGE RECORDED",BMCI=BMCI+1
I $D(^AUPNPAT(BMCDFN,13)) D
.S BMCMSG(BMCI)="",BMCI=BMCI+1,BMCMSG(BMCI)="ADDITIONAL REGISTRATION INFORMATION:",BMCI=BMCI+1
.K BMCAR D ENP^XBDIQ1(9000001,BMCDFN,1301,"BMCAR(","E")
.S I=0 F S I=$O(BMCAR(1301,I)) Q:I'=+I S BMCMSG(BMCI)=BMCAR(1301,I),BMCI=BMCI+1
W:BMCI !!
S BMCI=0
F S BMCI=$O(BMCMSG(BMCI)) Q:'BMCI W BMCMSG(BMCI),!
D PAUSE^BMC
Q
;
EOJ ; END OF JOB
D ^BMCKILL
Q
BMCALT ; IHS/PHXAO/TMJ - LIST ALTERNATE RESOURCES ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
+2 ;
+3 ; This routine lists alternate resources for the selected patient
+4 ;
START ;
+1 FOR
DO MAIN
IF BMCQ
QUIT
DO HDR^BMC
+2 DO EOJ
+3 QUIT
+4 ;
MAIN ;
+1 SET BMCQ=0
+2 ; get patient being referred
DO PATIENT
+3 IF BMCQ
QUIT
+4 ; list alternate resourece
DO LIST
+5 QUIT
+6 ;
PATIENT ; GET PATIENT
+1 FOR
DO PATIENT2
IF BMCQ!($GET(BMCDFN))
QUIT
+2 QUIT
+3 ;
PATIENT2 ; ASK FOR PATIENT UNTIL USER SELECTS OR QUITS
+1 SET BMCQ=1
+2 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO DIC^BMCFMC
+3 IF Y<1
QUIT
+4 SET BMCDFN=+Y
SET BMCREC("PAT NAME")=$PIECE(^DPT(+Y,0),U)
+5 SET BMCQ=0
+6 IF $$DOD^AUPNPAT(BMCDFN)
Begin DoDot:1
+7 WRITE !!,"This patient is deceased."
+8 SET DIR(0)="YO"
SET DIR("A")="Are you sure you want this patient"
SET DIR("B")="NO"
KILL DA
DO ^DIR
KILL DIR
+9 WRITE !
+10 QUIT
End DoDot:1
IF 'Y
KILL BMCDFN,BMCREC("PAT NAME")
QUIT
+11 QUIT
+12 ;
LIST ; LIST ALTERNATE RESOURCES
+1 IF '$GET(BMCDFN)
QUIT
+2 SET BMCRDATE=DT
+3 NEW BMCMSG,BMCI,BMCX
+4 SET BMCI=1
+5 SET BMCX=$$BEN^AUPNPAT(BMCDFN,"E")
+6 IF BMCX=""
SET BMCX="UNKNOWN"
+7 SET BMCMSG(BMCI)="CLASSIFICATION/BENEFICIARY IS: "_BMCX
SET BMCI=+BMCI+1
+8 SET BMCX=$$ELIGSTAT^AUPNPAT(BMCDFN,"E")
+9 IF BMCX=""
SET BMCX="UNKNOWN"
+10 SET BMCMSG(BMCI)="ELIGIBILITY STATUS IS: "_BMCX
SET BMCI=+BMCI+1
+11 NEW BMCELG
+12 SET BMCELG=BMCI
+13 IF $$MCR^AUPNPAT(BMCDFN,BMCRDATE)
SET BMCMSG(BMCI)="PATIENT HAS MEDICARE"
SET BMCI=BMCI+1
+14 ;I $$MCD^AUPNPAT(BMCDFN,BMCRDATE) S BMCMSG(BMCI)="PATIENT HAS MEDICAID--",BMCI=BMCI+1
+15 SET BMCX=$$MCDPN^AUPNPAT(BMCDFN,BMCRDATE,"E")
+16 IF BMCX=""
SET BMCX="UNKNOWN"
+17 IF $$MCD^AUPNPAT(BMCDFN,BMCRDATE)
SET BMCMSG(BMCI)="PATIENT HAS MEDICAID-PLAN NAME: "_BMCX
SET BMCI=+BMCI+1
+18 ;I $$PI^AUPNPAT(BMCDFN,BMCRDATE) S BMCMSG(BMCI)="PATIENT HAS PRIVATE INSURANCE--",BMCI=BMCI+1
+19 SET BMCX=$$PIN^AUPNPAT(BMCDFN,BMCRDATE,"E")
+20 IF BMCX=""
SET BMCX="UNKNOWN"
+21 IF $$PI^AUPNPAT(BMCDFN,BMCRDATE)
SET BMCMSG(BMCI)="PATIENT HAS INSURANCE-INSURER: "_BMCX
SET BMCI=BMCI+1
+22 IF BMCELG=BMCI
SET BMCMSG(BMCI)="NO THIRD PARTY COVERAGE RECORDED"
SET BMCI=BMCI+1
+23 IF $DATA(^AUPNPAT(BMCDFN,13))
Begin DoDot:1
+24 SET BMCMSG(BMCI)=""
SET BMCI=BMCI+1
SET BMCMSG(BMCI)="ADDITIONAL REGISTRATION INFORMATION:"
SET BMCI=BMCI+1
+25 KILL BMCAR
DO ENP^XBDIQ1(9000001,BMCDFN,1301,"BMCAR(","E")
+26 SET I=0
FOR
SET I=$ORDER(BMCAR(1301,I))
IF I'=+I
QUIT
SET BMCMSG(BMCI)=BMCAR(1301,I)
SET BMCI=BMCI+1
End DoDot:1
+27 IF BMCI
WRITE !!
+28 SET BMCI=0
+29 FOR
SET BMCI=$ORDER(BMCMSG(BMCI))
IF 'BMCI
QUIT
WRITE BMCMSG(BMCI),!
+30 DO PAUSE^BMC
+31 QUIT
+32 ;
EOJ ; END OF JOB
+1 DO ^BMCKILL
+2 QUIT
