- 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
