Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BSDAIU

BSDAIU.m

Go to the documentation of this file. 
  1. BSDAIU ; IHS/ANMC/LJF - ADDRESS & INSURANCE UPDATE ; 
  1.  ;;5.3;PIMS;**1007,1010,1012,1019**;APR 26, 2002;Build 3
  1.  ;
  1.  ;cmi/anch/maw 09/01/2008 PIMS Patch 1010 RQMT33 added number in household and income in DEM
  1.  ;cmi/anch/maw 09/01/2008 PIMS Patch 1010 RQMT6 added mother and fathers employer name
  1.  ;cmi/flag/maw 05/14/2010 PIMS Patch 1012 RQMT142 added call to this report from Appointment Managment
  1.  ;
  1.  ;
  1. OR ;EP - called from Other Reports on Appointment Management if no patient
  1.  I $G(DFN) D PATE Q  ;cmi/maw 05/14/2010 skip patient if already exists
  1.  NEW DFN,BSDFORM
  1.  S DFN=+$$READ^BDGF("PO^2:QEMZ","Select PATIENT") Q:'DFN
  1. PATE ;EP - called from Other Reports on Appointment Management if patient
  1.  D ZIS^BDGF("PQ","BEGIN^BSDAIU","ADDRESS/INSURANCE FORM","DFN")
  1.  Q
  1.  ;
  1.  ;
  1. BEGIN ;EP;  entry point from queuing and from BSDFORM
  1.  U IO
  1.  D DEM,EC,TRIBE,PRVT,MCR,MCD,PRT2
  1.  ;
  1.  I '$G(BSDFORM) D ^%ZISC      ;close device if not called within a loop
  1.  D KILL^AUPNPAT               ;kill patient variables
  1.  Q
  1.  ;
  1. DEM ;-- print demographics
  1.  NEW X,I
  1.  S X=$$DIVNM^BSDU($$DIV^BSDU) W !!,?80-$L(X)\2,X         ;division
  1.  W !?16,$$CONF^BSDU
  1.  W !,?17,"*** PATIENT ADDRESS AND INSURANCE UPDATE ***"
  1.  W !,?9,"*** PLEASE MAKE CORRECTIONS TO ANY INCORRECT INFORMATION ***"
  1.  W !!,$E($$GET1^DIQ(2,DFN,.01),1,27)                     ;pat name
  1.  W ?30,"HRCN: ",$$HRCN^BDGF2(DFN,+$G(DUZ(2)))            ;chart #
  1.  W ?44,"DOB: ",$$GET1^DIQ(2,DFN,.03)                     ;date of birth
  1.  W ?62,"AGE: ",$$GET1^DIQ(9000001,DFN,1102.98)           ;printable age
  1.  W !,"SSN: ","XXX-XX-"_$E($$GET1^DIQ(2,DFN,.09),6,9)     ;ssn
  1.  ;
  1.  I $$GET1^DIQ(9000001,DFN,1112)["PENDING" D
  1.  . W !!,$$REPEAT^XLFSTR("*",80)
  1.  . W !?3,"ELIGIBILITY PENDING - HAVE PATIENT SEE APPROPRIATE PERSONNEL FOR VERIFICATION"
  1.  . W !!,$$REPEAT^XLFSTR("*",80)
  1.  ;
  1.  I $G(^DPT(DFN,.11))="" D
  1.  . W !,?3,"Please enter your address,work and phone number on "
  1.  . W "the line below."
  1.  . W !!,?3," " N X S $P(X,"_",75)="" W X K X
  1.  E  D
  1.  . ;address and phone number
  1.  . W ! F I=.111,.112,.113 S X=$$GET1^DIQ(2,DFN,I) I X]"" W !,X  ;street
  1.  . W ?48,"Home: ",$$GET1^DIQ(2,DFN,.131)                   ;home phone
  1.  . W !,$$GET1^DIQ(2,DFN,.114),", ",$$STATE(2,DFN,.115)     ;city,state
  1.  . W " ",$$GET1^DIQ(2,DFN,.116)                            ;zip
  1.  . W ?48,"Birth Place: ",$$STATE(2,DFN,.093)               ;birth state
  1.  ;
  1.  W !!,?3,"Employer: ",$$GET1^DIQ(9000001,DFN,.19)          ;employer
  1.  W ?48,"Work Phone: ",$$GET1^DIQ(2,DFN,.132)               ;work phone
  1.  W !,?3,"Spouse's Employer: ",$$GET1^DIQ(9000001,DFN,.22)  ;spouse empl
  1.  W ?48,"Work Phone: ",$$GET1^DIQ(2,DFN,.258)               ;spouse phon
  1.  ;
  1.  W !!,?3,"Father's Name: ",$$GET1^DIQ(2,DFN,.2401)         ;father
  1.  W ?48,"Birthplace: ",$$GET1^DIQ(9000001,DFN,2602)_", "    ;birth city
  1.  W $$STATE(9000001,DFN,2603)                               ;birth state
  1.  W !,?3,"Father's Employer: ",$$GET1^DIQ(9000001,DFN,2701)  ;fathers employer name cmi/maw 9/1/2008 PIMS Patch 1010 RQMT6
  1.  W !,?3,"Mother's Name: ",$$GET1^DIQ(2,DFN,.2403)          ;maiden name
  1.  W ?48,"Birthplace: ",$$GET1^DIQ(9000001,DFN,2605)_", "    ;birth city
  1.  W $$STATE(9000001,DFN,2606)                               ;birth state
  1.  W !,?3,"Mother's Employer: ",$$GET1^DIQ(9000001,DFN,2702)  ;mothers employer name cmi/maw 9/1/2008 PIMS Patch 1010 RQMT6
  1.  W !!?3,"Number in Household: ",$$GET1^DIQ(9000001,DFN,.35)  ;number in household cmi/maw 9/1/2008 PIMS Patch 1010 RQMT33
  1.  W ?48,"Household Income: ",$$GET1^DIQ(9000001,DFN,.36)    ;household income cmi/maw 9/1/2008 PIMS Patch 1010 RQMT33 
  1.  Q
  1.  ;
  1. EC ; emergency contact info
  1.  W !!,?3,"Emergency Contact: ",$$GET1^DIQ(2,DFN,.331)      ;ec name
  1.  W !,?3,"Relationship: ",$$GET1^DIQ(2,DFN,.332)            ;ec relation
  1.  ;W ?48,"Phone No.: ",$$GET1^DIQ(2,DFN,339)                 ;ec phone cmi/anch/maw 6/29/2007 orig code PATCH 1007
  1.  W ?48,"Phone No.: ",$$GET1^DIQ(2,DFN,.339)                 ;ec phone cmi/anch/maw 6/29/2007 mod code PATCH 1007
  1.  W !,?3,"Mailing Address: ",$$GET1^DIQ(2,DFN,.333)         ;ec street
  1.  W !,?3,"City: ",$$GET1^DIQ(2,DFN,.336)                    ;ec city
  1.  W ?28,"State: ",$$STATE(2,DFN,.337)                       ;ec state
  1.  W ?48,"Zip: ",$$GET1^DIQ(2,DFN,.338)                      ;ec zip
  1.  Q
  1.  ;
  1. TRIBE ; print tribe info
  1.  W !!,"ELIGIBILITY: ",$$GET1^DIQ(9000001,DFN,1112),!
  1.  W !,"TRIBE OF MEMBERSHIP/CORP.   BLOOD QUANTUM   TRIBE QUANTUM   TRIBE"
  1.  W !,"-------------------------   -------------   -------------   -----"
  1.  W !,$E($$GET1^DIQ(9000001,DFN,1108),1,25)                 ;tribe/corp
  1.  W ?29,$$GET1^DIQ(9000001,DFN,1110)                        ;blood quant
  1.  W ?45,$$GET1^DIQ(9000001,DFN,1109)                        ;tribe quant
  1.  W ?60,$E($$GET1^DIQ(9000001,DFN,1127),1,5)                ;old tribe
  1.  Q
  1.  ;
  1. PRVT ;find private insurance
  1.  W !!,?3,"INSURANCE COMPANY",?35,"POLICY #",?51,"ELIGIBILITY DATES",!
  1.  W ?3,$$REPEAT^XLFSTR("-",27),?35,$$REPEAT^XLFSTR("-",12)
  1.  W ?51,$$REPEAT^XLFSTR("-",26)
  1.  ;
  1.  I '$D(^AUPNPRVT(DFN)) D  Q
  1.  . W !,"   *** NO PRIVATE INSURANCE INFORMATION ON RECORD ***"
  1.  ;
  1.  NEW X,Y,X0,Y0
  1.  S X=0 F  S X=$O(^AUPNPRVT(DFN,11,X)) Q:'X  D
  1.  . Q:'$D(^AUPNPRVT(DFN,11,X,0))  S X0=^(0)
  1.  . S Y=+X0 Q:'Y!('$D(^AUTNINS(+Y,0)))  S Y0=^(0)
  1.  . W !,?3,$P(Y0,U),?35,$P(X0,U,2)
  1.  . I +$P(X0,U,6) D
  1.  .. N Y S Y=$P(X0,U,6) X ^DD("DD") W ?51,Y," to "
  1.  . I +$P(X0,U,7) D
  1.  .. N Y S Y=$P(X0,U,7) X ^DD("DD") W ?66,Y
  1.  Q
  1.  ;
  1. MCR ;find medicare information
  1.  W !!,?3,"MEDICARE NUMBER",?21,"RELEASE DATE"
  1.  W ?35,"MEDICARE ELIGIBILITY DATES/COVERAGE"
  1.  N X,Y,Z S $P(X,"-",16)="",$P(Y,"-",12)="",$P(Z,"-",36)=""
  1.  W !,?3,$$REPEAT^XLFSTR("-",16),?21,$$REPEAT^XLFSTR("-",12)
  1.  W ?35,$$REPEAT^XLFSTR("-",36)
  1.  ;
  1.  I '$D(^AUPNMCR(DFN)) D  Q
  1.  . W !,"   *** NO MEDICARE INFORMATION ON RECORD ***"
  1.  ;
  1.  N X,Y,X0,Y0
  1.  S X0=^AUPNMCR(DFN,0) D
  1.  . S Y=$P(X0,U,3) Q:'Y  W !,?3,Y               ;medicare number
  1.  . S Y=$P(X0,U,4) Q:'Y!('$D(^AUTTMCS(+Y,0)))  S Y0=^(0) W ?14,Y0
  1.  W ?21,$$GET1^DIQ(9000001,DFN,.04)
  1.  S X=0
  1.  F  S X=$O(^AUPNMCR(DFN,11,X)) Q:'X  D
  1.  . Q:'$D(^AUPNMCR(DFN,11,X,0))  S X0=^(0)
  1.  . I $P(X0,U) D
  1.  .. N Y S Y=$P(X0,U) X ^DD("DD") W ?35,Y," to "
  1.  . I $P(X0,U,2) D
  1.  .. N Y S Y=$P(X0,U,2) X ^DD("DD") W ?50,Y
  1.  . I $P(X0,U,3)'="" D
  1.  .. N Y S Y=$P(X0,U,3) W ?65,Y
  1.  . W !
  1.  Q
  1.  ;
  1. MCD ;find medicaid information 
  1.  W !!,?3,"MEDICAID NUMBER",?35,"MEDICAID ELIGIBILITY DATES/COVERAGE"
  1.  W !?3,$$REPEAT^XLFSTR("-",16),?35,$$REPEAT^XLFSTR("-",36)
  1.  ;
  1.  I '$D(^AUPNMCD("B",DFN)) D  Q
  1.  . W !,"   *** NO MEDICAID INFORMATION ON RECORD ***"
  1.  ;
  1.  NEW X,Y,Z,X0,Y0,IFN
  1.  S IFN=0 F  S IFN=$O(^AUPNMCD("B",DFN,IFN)) Q:IFN=""  D
  1.  . S X0=^AUPNMCD(IFN,0) D
  1.  .. S Y=$P(X0,U,3) W !,?3,Y               ;medicaid number
  1.  .. S Y=$P(X0,U,4) Q:'Y!('$D(^DIC(5,+Y,0)))  S Y0=$P(^(0),U,2) W ?14,Y0
  1.  .. S Y=$S($P(X0,U,8):$P(X0,U,8),1:"") Q:'Y  X ^DD("DD") S Z=Y
  1.  . S X=0 F  S X=$O(^AUPNMCD(IFN,11,X)) Q:'X  D
  1.  .. Q:'$D(^AUPNMCD(IFN,11,X,0))  S X0=^(0)
  1.  .. I $P(X0,U) D
  1.  ... N Y S Y=$P(X0,U) X ^DD("DD") W ?35,Y," to "
  1.  .. I $P(X0,U,2) D
  1.  ... N Y S Y=$P(X0,U,2) X ^DD("DD") W ?50,Y
  1.  .. I $P(X0,U,3)'="" D
  1.  ... N Y S Y=$P(X0,U,3) W ?65,Y
  1.  I $G(Z) W !!,?3,"Medicaid date of last update: ",Z,!
  1.  Q
  1.  ;
  1. PRT2 ;print request for current information
  1.  NEW X,Y
  1.  W !!,?3,"Does this include Dental coverage?  Yes___  No___"
  1.  W !!,?3,"Is this a work related Injury?      Yes___ No___",!
  1.  W ?3,"Date of Injury: _______________________"
  1.  W !!,?8,"We appreciate your cooperation and assistance in filling"
  1.  W " out this form."
  1.  W !,?3,"It is important that we keep our patient registration"
  1.  W " files accurate so"
  1.  W !,?3,"that we can provide a better service to you."
  1.  W !!,?3,"The Business Office, ",$$GET1^DIQ(9999999.06,DUZ(2),.02)
  1.  W ?50,"Printed ",$$TIME^BDGF($$NOW^XLFDT),"  ",$$FMTE^XLFDT(DT)
  1.  Q
  1.  ;
  1. STATE(FILE,PAT,FIELD) ; returns state abbreviation for state field sent
  1.  NEW X S X=$$GET1^DIQ(FILE,PAT,FIELD,"I")
  1.  Q $$GET1^DIQ(5,+X,1)