- ASDAIU ; IHS/ADC/PDW/ENM - ADDRESS & INSURANCE UPDATE ; [ 03/25/1999 11:48 AM ]
- ;;5.0;IHS SCHEDULING;;MAR 25, 1999
- ;
- D SP Q:'$D(DFN)
- D DEV I POP!($D(IO("Q"))) D END Q
- D SET,END Q
- ;
- SP ; -- select patient
- N DIC,Y,X S DIC="^DPT(",DIC(0)="AEQMZ"
- D ^DIC K DIC Q:Y'>0 S DFN=+Y Q
- ;
- DEV ; select device
- K IOP,POP S %ZIS="PQ" D ^%ZIS Q:POP D QUE:$D(IO("Q")) Q
- ;
- QUE ; -- queued output
- S ZTRTN="SET^ASDAIU",ZTDESC="ADDRESS/INSURANCE FORM",ZTSAVE("DFN")=""
- D ^%ZTLOAD Q
- ;
- SET ;EP; called by ZTLOAD and by RS/HS prints
- NEW SDDPTN0,SSN,SDELIG,SDDPTN13,NAME,HRCN,DOB,ADDR,SITE,Y
- S SDDPTN0=^DPT(DFN,0),SSN=$P(SDDPTN0,U,9),NAME=$P(SDDPTN0,U)
- S PNODE=^AUPNPAT(DFN,0)
- D EMPY,SEMPY
- S FMBIRTH=$G(^AUPNPAT(DFN,26)) D PARENT
- S PBIRTH=$P(SDDPTN0,U,11)
- S SDELIG=$S($P($G(^AUPNPAT(DFN,11)),U,12)]"":$P($G(^(11)),U,12),1:"")
- S SDDPTN13=$G(^DPT(DFN,.13)),SITE=$P(^DIC(4,DUZ(2),0),U)
- S ADDR=$G(^DPT(DFN,.11)),HRCN=$$HRCN^ASDUT
- S EPHONE=$P($G(^DPT(DFN,.311)),U,9)
- S SPHONE=$P($G(^DPT(DFN,.25)),U,8)
- S MNAME=$P($G(^DPT(DFN,.24)),U,3),FNAME=$P($G(^DPT(DFN,.24)),U)
- S NKNODE=$G(^DPT(DFN,.21)),NKNAME=$P(NKNODE,U),NKREL=$P(NKNODE,U,2)
- S NKPHONE=$P(NKNODE,U,9),NKADD=$P(NKNODE,U,3),NKCITY=$P(NKNODE,U,6)
- S NKSTP=$P(NKNODE,U,7),NKST=$P($G(^DIC(5,+NKSTP,0)),U)
- S NKZIP=$P(NKNODE,U,8)
- S Y=$P(SDDPTN0,U,3) I Y X ^DD("DD") S DOB=Y
- ;
- BEGIN ;-- begin
- D DEM,TRIBE,PRVT,MCR,MCD,PRT2
- Q
- ;
- END ;-- kill variables
- D ^%ZISC
- END1 ;EP; called by ASDFORM
- K NKADD,NKCITY,NKNAME,NKNODE,NKPHONE,NKREL,NKST,NKSTP,NKZIP
- K PBIRTH,SEMPY,SPHONE,FSBIRTH,FCBIRTH,FMBIRTH,MSBIRTH,MCBIRTH
- K FSBIRTHP,MSBIRTHP,DFN,EMPY,EPHONE,FNAME,MNAME,PNODE,SEMPYP,AUPNDOB
- K AUPNDAYS,AUPNPAT,AUPNSEX,LL,SEX,SSN,POP,AUPNDOD,DOB,AGE
- Q
- ;
- DEM ;-- print demographics
- U IO
- W @IOF ;maw added form feed at print
- W !!,?80-$L(SITE)\2,SITE
- W !?16,$$CONF^ASDUT
- W !,?17,"*** PATIENT ADDRESS AND INSURANCE UPDATE ***"
- W !,?9,"*** PLEASE MAKE CORRECTIONS TO ANY INCORRECT INFORMATION ***"
- W !!,$E(NAME,1,27)
- ;-- searhc/maw start of mods 5/19
- W ?30,"HRCN: ",HRCN,?44,"DOB: ",DOB,?62,"AGE: ",$$AGE
- W !,"SSN: ",SSN
- ;W ?34,"HRCN: ",HRCN,?48,"DOB: ",DOB,?66,"SSN: ",SSN ;maw orig line
- ;-- searhc/maw end of mods 5/19
- I SDELIG["P" D
- . W !!,?3,"***** ELIGIBILITY PENDING - "
- . W "PLEASE SEND PATIENT TO ADMITTING *****"
- I ADDR="" D G EMPLY
- . W !,?3,"Please enter your address,work and phone number on "
- . W "the line below."
- . W !!,?3," " N X S $P(X,"_",75)="" W X K X
- W ! F LL=1,2,3 W:$P(ADDR,U,LL)]"" !,$P(ADDR,U,LL)
- W ?48,"Home: ",$P(SDDPTN13,U,1)
- W !,$P(ADDR,U,4),","
- W:$D(^DIC(5,+$P(ADDR,U,5),0)) $P(^(0),U,2)
- W " "_$P(ADDR,U,6),?48,"Birth Place: ",PBIRTH
- EMPLY W !!,?3,"Employer: ",EMPY,?48,"Work Phone: ",$P(SDDPTN13,U,2)
- W !,?3,"Spouse's Employer: ",SEMPY,?48,"Work Phone: ",SPHONE
- W !!,?3,"Father's Name: ",FNAME,?48,"Birthplace: ",FCBIRTH_" "_FSBIRTH
- W !,?3,"Mother's Name: ",MNAME,?48,"Birthplace: ",MCBIRTH_" "_MSBIRTH
- W !!,?3,"Emergency Contact: ",NKNAME
- W !,?3,"Relationship: ",NKREL,?48,"Phone No.: ",NKPHONE
- W !,?3,"Mailing Address: ",NKADD
- W !,?3,"City: ",NKCITY,?28,"State: ",NKST,?48,"Zip: ",NKZIP
- Q
- ;
- TRIBE ;
- S N=$G(^AUPNPAT(DFN,11)) W !!
- W !,"ELIGIBILITY: " ;maw added
- S ELG=$P(N,U,12) ;maw added
- W $S(ELG="I":"INELIGIBLE",ELG="C":"CHS & DIRECT",ELG="D":"DIRECT ONLY",ELG="P":"PENDING VERIFICATION",1:"") ;maw added
- W !,"TRIBE OF MEMBERSHIP/CORP. BLOOD QUANTUM TRIBE QUANTUM TRIBE"
- W !,"------------------------- ------------- ------------- -----"
- W !,$E($P($G(^AUTTTRI(+$P(N,U,8),0)),U),1,25)
- W ?29,$P(N,U,10),?45,$P(N,U,9)
- W ?60,$P($G(^AUTTTRI(+$P(N,U,27),0)),U),! K N
- Q
- ;
- PRVT1 ;print header for private insurance
- W !,?3,"INSURANCE COMPANY",?35,"POLICY #",?51,"ELIGIBILITY DATES",!
- N X,Y,Z S $P(X,"-",27)="",$P(Y,"-",12)="",$P(Z,"-",26)=""
- W ?3,X,?35,Y,?51,Z Q
- ;
- MCR1 ;print medicare header
- W !!,?3,"MEDICARE NUMBER",?21,"RELEASE DATE"
- W ?35,"MEDICARE ELIGIBILITY DATES/COVERAGE"
- N X,Y,Z S $P(X,"-",16)="",$P(Y,"-",12)="",$P(Z,"-",36)=""
- W !,?3,X,?21,Y,?35,Z Q
- ;
- MCD1 ;print medicaid header
- W !!,?3,"MEDICAID NUMBER",?35,"MEDICAID ELIGIBILITY DATES/COVERAGE"
- N X,Y S $P(X,"-",16)="",$P(Y,"-",36)="" W !,?3,X,?35,Y Q
- ;
- PRVT ;find private insurance
- NEW X,Y,X0,Y0
- I '$D(^AUPNPRVT(DFN)) D Q
- . W !," *** NO PRIVATE INSURANCE INFORMATION ON RECORD ***"
- D PRVT1 S X=0
- F S X=$O(^AUPNPRVT(DFN,11,X)) Q:'X D
- . Q:'$D(^AUPNPRVT(DFN,11,X,0)) S X0=^(0)
- . S Y=+X0 Q:'Y!('$D(^AUTNINS(+Y,0))) S Y0=^(0)
- . W !,?3,$P(Y0,U),?35,$P(X0,U,2)
- . I +$P(X0,U,6) D
- .. N Y S Y=$P(X0,U,6) X ^DD("DD") W ?51,Y," to "
- . I +$P(X0,U,7) D
- .. N Y S Y=$P(X0,U,7) X ^DD("DD") W ?66,Y
- Q
- ;
- MCR ;find medicare information
- N X,Y,X0,Y0
- I '$D(^AUPNMCR(DFN)) D Q
- . W !," *** NO MEDICARE INFORMATION ON RECORD ***"
- D MCR1 S X0=^AUPNMCR(DFN,0) D
- . S Y=$P(X0,U,3) Q:'Y W !,?3,Y ;medicare number
- . S Y=$P(X0,U,4) Q:'Y!('$D(^AUTTMCS(+Y,0))) S Y0=^(0) W ?14,Y0
- W ?21,$$VAL^XBDIQ1(9000001,DFN,.04)
- S X=0
- F S X=$O(^AUPNMCR(DFN,11,X)) Q:'X D
- . Q:'$D(^AUPNMCR(DFN,11,X,0)) S X0=^(0)
- . I $P(X0,U) D
- .. N Y S Y=$P(X0,U) X ^DD("DD") W ?35,Y," to "
- . I $P(X0,U,2) D
- .. N Y S Y=$P(X0,U,2) X ^DD("DD") W ?50,Y
- . I $P(X0,U,3)'="" D
- .. N Y S Y=$P(X0,U,3) W ?65,Y
- . W !
- Q
- ;
- MCD ;find medicaid information
- ;
- NEW X,Y,Z,X0,Y0,IFN
- I '$D(^AUPNMCD("B",DFN)) D Q
- . W !," *** NO MEDICAID INFORMATION ON RECORD ***"
- D MCD1 S IFN=0 F S IFN=$O(^AUPNMCD("B",DFN,IFN)) Q:IFN="" D
- . S X0=^AUPNMCD(IFN,0) D
- .. S Y=$P(X0,U,3) W !,?3,Y ;medicaid number
- .. S Y=$P(X0,U,4) Q:'Y!('$D(^DIC(5,+Y,0))) S Y0=$P(^(0),U,2) W ?14,Y0
- .. S Y=$S($P(X0,U,8):$P(X0,U,8),1:"") Q:'Y X ^DD("DD") S Z=Y
- . S X=0 F S X=$O(^AUPNMCD(IFN,11,X)) Q:'X D
- .. Q:'$D(^AUPNMCD(IFN,11,X,0)) S X0=^(0)
- .. I $P(X0,U) D
- ... N Y S Y=$P(X0,U) X ^DD("DD") W ?35,Y," to "
- .. I $P(X0,U,2) D
- ... N Y S Y=$P(X0,U,2) X ^DD("DD") W ?50,Y
- .. I $P(X0,U,3)'="" D
- ... N Y S Y=$P(X0,U,3) W ?65,Y
- I $G(Z) W !!,?3,"Medicaid date of last update: ",Z,!
- Q
- ;
- PRT2 ;print request for current information
- NEW X,Y
- W !!,?3,"Does this include Dental coverage? Yes___ No___"
- W !!,?3,"Is this a work related Injury? Yes___ No___",!
- W ?3,"Date of Injury: _______________________"
- W !!,?8,"We appreciate your cooperation and assistance in filling"
- W " out this form."
- W !,?3,"It is important that we keep our patient registration"
- W " files accurate so"
- W !,?3,"that we can provide a better service to you."
- W !!,?3,"The Business Office, ",SITE,?50,"Printed at "
- D TIME^ASDUT W " " D ^%D
- Q
- ;
- ;
- PARENT ; -- parents' birth info
- I FMBIRTH="" S (MCBIRTH,MSBIRTH,FCBIRTH,FSBIRTH)=" " Q
- S MCBIRTH=$P($G(FMBIRTH),U,5),MSBIRTHP=$P($G(FMBIRTH),U,6)
- S MSBIRTH=$P($G(^DIC(5,+MSBIRTHP,0)),U,2),FCBIRTH=$P($G(FMBIRTH),U,2)
- S FSBIRTHP=$P($G(FMBIRTH),U,3),FSBIRTH=$P($G(^DIC(5,+FSBIRTHP,0)),U,2)
- Q
- EMPY ; -- employer name
- S EMPY=$P($G(PNODE),U,19) I EMPY="" S EMPY="NONE" Q
- S EMPY=$P($G(^AUTNEMPL(EMPY,0)),U) Q
- ;
- SEMPY ; -- spouse employer
- N Y S SEMPYP=$P($G(PNODE),U,22) I SEMPYP="" S SEMPY="NONE" Q
- S SEMPY=$P($G(^AUTNEMPL(SEMPYP,0)),U)
- Q
- ;
- AGE() ; -- get the printable age
- N DA
- S DA=DFN
- ;S DR=1102.98,DIC=9000001 D ^AUDICLK ;IHS/DSD/ENM 01/22/99
- S DR=1102.98,DIC=9000001 D ^ASDZAGE ;IHS/DSD/ENM 01/22/99
- S AGE=$S($D(LKPRINT):LKPRINT,1:"")
- Q AGE
- ;
- ASDAIU ; IHS/ADC/PDW/ENM - ADDRESS & INSURANCE UPDATE ; [ 03/25/1999 11:48 AM ]
- +1 ;;5.0;IHS SCHEDULING;;MAR 25, 1999
- +2 ;
- +3 DO SP
- IF '$DATA(DFN)
- QUIT
- +4 DO DEV
- IF POP!($DATA(IO("Q")))
- DO END
- QUIT
- +5 DO SET
- DO END
- QUIT
- +6 ;
- SP ; -- select patient
- +1 NEW DIC,Y,X
- SET DIC="^DPT("
- SET DIC(0)="AEQMZ"
- +2 DO ^DIC
- KILL DIC
- IF Y'>0
- QUIT
- SET DFN=+Y
- QUIT
- +3 ;
- DEV ; select device
- +1 KILL IOP,POP
- SET %ZIS="PQ"
- DO ^%ZIS
- IF POP
- QUIT
- IF $DATA(IO("Q"))
- DO QUE
- QUIT
- +2 ;
- QUE ; -- queued output
- +1 SET ZTRTN="SET^ASDAIU"
- SET ZTDESC="ADDRESS/INSURANCE FORM"
- SET ZTSAVE("DFN")=""
- +2 DO ^%ZTLOAD
- QUIT
- +3 ;
- SET ;EP; called by ZTLOAD and by RS/HS prints
- +1 NEW SDDPTN0,SSN,SDELIG,SDDPTN13,NAME,HRCN,DOB,ADDR,SITE,Y
- +2 SET SDDPTN0=^DPT(DFN,0)
- SET SSN=$PIECE(SDDPTN0,U,9)
- SET NAME=$PIECE(SDDPTN0,U)
- +3 SET PNODE=^AUPNPAT(DFN,0)
- +4 DO EMPY
- DO SEMPY
- +5 SET FMBIRTH=$GET(^AUPNPAT(DFN,26))
- DO PARENT
- +6 SET PBIRTH=$PIECE(SDDPTN0,U,11)
- +7 SET SDELIG=$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,12)]"":$PIECE($GET(^(11)),U,12),1:"")
- +8 SET SDDPTN13=$GET(^DPT(DFN,.13))
- SET SITE=$PIECE(^DIC(4,DUZ(2),0),U)
- +9 SET ADDR=$GET(^DPT(DFN,.11))
- SET HRCN=$$HRCN^ASDUT
- +10 SET EPHONE=$PIECE($GET(^DPT(DFN,.311)),U,9)
- +11 SET SPHONE=$PIECE($GET(^DPT(DFN,.25)),U,8)
- +12 SET MNAME=$PIECE($GET(^DPT(DFN,.24)),U,3)
- SET FNAME=$PIECE($GET(^DPT(DFN,.24)),U)
- +13 SET NKNODE=$GET(^DPT(DFN,.21))
- SET NKNAME=$PIECE(NKNODE,U)
- SET NKREL=$PIECE(NKNODE,U,2)
- +14 SET NKPHONE=$PIECE(NKNODE,U,9)
- SET NKADD=$PIECE(NKNODE,U,3)
- SET NKCITY=$PIECE(NKNODE,U,6)
- +15 SET NKSTP=$PIECE(NKNODE,U,7)
- SET NKST=$PIECE($GET(^DIC(5,+NKSTP,0)),U)
- +16 SET NKZIP=$PIECE(NKNODE,U,8)
- +17 SET Y=$PIECE(SDDPTN0,U,3)
- IF Y
- XECUTE ^DD("DD")
- SET DOB=Y
- +18 ;
- BEGIN ;-- begin
- +1 DO DEM
- DO TRIBE
- DO PRVT
- DO MCR
- DO MCD
- DO PRT2
- +2 QUIT
- +3 ;
- END ;-- kill variables
- +1 DO ^%ZISC
- END1 ;EP; called by ASDFORM
- +1 KILL NKADD,NKCITY,NKNAME,NKNODE,NKPHONE,NKREL,NKST,NKSTP,NKZIP
- +2 KILL PBIRTH,SEMPY,SPHONE,FSBIRTH,FCBIRTH,FMBIRTH,MSBIRTH,MCBIRTH
- +3 KILL FSBIRTHP,MSBIRTHP,DFN,EMPY,EPHONE,FNAME,MNAME,PNODE,SEMPYP,AUPNDOB
- +4 KILL AUPNDAYS,AUPNPAT,AUPNSEX,LL,SEX,SSN,POP,AUPNDOD,DOB,AGE
- +5 QUIT
- +6 ;
- DEM ;-- print demographics
- +1 USE IO
- +2 ;maw added form feed at print
- WRITE @IOF
- +3 WRITE !!,?80-$LENGTH(SITE)\2,SITE
- +4 WRITE !?16,$$CONF^ASDUT
- +5 WRITE !,?17,"*** PATIENT ADDRESS AND INSURANCE UPDATE ***"
- +6 WRITE !,?9,"*** PLEASE MAKE CORRECTIONS TO ANY INCORRECT INFORMATION ***"
- +7 WRITE !!,$EXTRACT(NAME,1,27)
- +8 ;-- searhc/maw start of mods 5/19
- +9 WRITE ?30,"HRCN: ",HRCN,?44,"DOB: ",DOB,?62,"AGE: ",$$AGE
- +10 WRITE !,"SSN: ",SSN
- +11 ;W ?34,"HRCN: ",HRCN,?48,"DOB: ",DOB,?66,"SSN: ",SSN ;maw orig line
- +12 ;-- searhc/maw end of mods 5/19
- +13 IF SDELIG["P"
- Begin DoDot:1
- +14 WRITE !!,?3,"***** ELIGIBILITY PENDING - "
- +15 WRITE "PLEASE SEND PATIENT TO ADMITTING *****"
- End DoDot:1
- +16 IF ADDR=""
- Begin DoDot:1
- +17 WRITE !,?3,"Please enter your address,work and phone number on "
- +18 WRITE "the line below."
- +19 WRITE !!,?3," "
- NEW X
- SET $PIECE(X,"_",75)=""
- WRITE X
- KILL X
- End DoDot:1
- GOTO EMPLY
- +20 WRITE !
- FOR LL=1,2,3
- IF $PIECE(ADDR,U,LL)]""
- WRITE !,$PIECE(ADDR,U,LL)
- +21 WRITE ?48,"Home: ",$PIECE(SDDPTN13,U,1)
- +22 WRITE !,$PIECE(ADDR,U,4),","
- +23 IF $DATA(^DIC(5,+$PIECE(ADDR,U,5),0))
- WRITE $PIECE(^(0),U,2)
- +24 WRITE " "_$PIECE(ADDR,U,6),?48,"Birth Place: ",PBIRTH
- EMPLY WRITE !!,?3,"Employer: ",EMPY,?48,"Work Phone: ",$PIECE(SDDPTN13,U,2)
- +1 WRITE !,?3,"Spouse's Employer: ",SEMPY,?48,"Work Phone: ",SPHONE
- +2 WRITE !!,?3,"Father's Name: ",FNAME,?48,"Birthplace: ",FCBIRTH_" "_FSBIRTH
- +3 WRITE !,?3,"Mother's Name: ",MNAME,?48,"Birthplace: ",MCBIRTH_" "_MSBIRTH
- +4 WRITE !!,?3,"Emergency Contact: ",NKNAME
- +5 WRITE !,?3,"Relationship: ",NKREL,?48,"Phone No.: ",NKPHONE
- +6 WRITE !,?3,"Mailing Address: ",NKADD
- +7 WRITE !,?3,"City: ",NKCITY,?28,"State: ",NKST,?48,"Zip: ",NKZIP
- +8 QUIT
- +9 ;
- TRIBE ;
- +1 SET N=$GET(^AUPNPAT(DFN,11))
- WRITE !!
- +2 ;maw added
- WRITE !,"ELIGIBILITY: "
- +3 ;maw added
- SET ELG=$PIECE(N,U,12)
- +4 ;maw added
- WRITE $SELECT(ELG="I":"INELIGIBLE",ELG="C":"CHS & DIRECT",ELG="D":"DIRECT ONLY",ELG="P":"PENDING VERIFICATION",1:"")
- +5 WRITE !,"TRIBE OF MEMBERSHIP/CORP. BLOOD QUANTUM TRIBE QUANTUM TRIBE"
- +6 WRITE !,"------------------------- ------------- ------------- -----"
- +7 WRITE !,$EXTRACT($PIECE($GET(^AUTTTRI(+$PIECE(N,U,8),0)),U),1,25)
- +8 WRITE ?29,$PIECE(N,U,10),?45,$PIECE(N,U,9)
- +9 WRITE ?60,$PIECE($GET(^AUTTTRI(+$PIECE(N,U,27),0)),U),!
- KILL N
- +10 QUIT
- +11 ;
- PRVT1 ;print header for private insurance
- +1 WRITE !,?3,"INSURANCE COMPANY",?35,"POLICY #",?51,"ELIGIBILITY DATES",!
- +2 NEW X,Y,Z
- SET $PIECE(X,"-",27)=""
- SET $PIECE(Y,"-",12)=""
- SET $PIECE(Z,"-",26)=""
- +3 WRITE ?3,X,?35,Y,?51,Z
- QUIT
- +4 ;
- MCR1 ;print medicare header
- +1 WRITE !!,?3,"MEDICARE NUMBER",?21,"RELEASE DATE"
- +2 WRITE ?35,"MEDICARE ELIGIBILITY DATES/COVERAGE"
- +3 NEW X,Y,Z
- SET $PIECE(X,"-",16)=""
- SET $PIECE(Y,"-",12)=""
- SET $PIECE(Z,"-",36)=""
- +4 WRITE !,?3,X,?21,Y,?35,Z
- QUIT
- +5 ;
- MCD1 ;print medicaid header
- +1 WRITE !!,?3,"MEDICAID NUMBER",?35,"MEDICAID ELIGIBILITY DATES/COVERAGE"
- +2 NEW X,Y
- SET $PIECE(X,"-",16)=""
- SET $PIECE(Y,"-",36)=""
- WRITE !,?3,X,?35,Y
- QUIT
- +3 ;
- PRVT ;find private insurance
- +1 NEW X,Y,X0,Y0
- +2 IF '$DATA(^AUPNPRVT(DFN))
- Begin DoDot:1
- +3 WRITE !," *** NO PRIVATE INSURANCE INFORMATION ON RECORD ***"
- End DoDot:1
- QUIT
- +4 DO PRVT1
- SET X=0
- +5 FOR
- SET X=$ORDER(^AUPNPRVT(DFN,11,X))
- IF 'X
- QUIT
- Begin DoDot:1
- +6 IF '$DATA(^AUPNPRVT(DFN,11,X,0))
- QUIT
- SET X0=^(0)
- +7 SET Y=+X0
- IF 'Y!('$DATA(^AUTNINS(+Y,0)))
- QUIT
- SET Y0=^(0)
- +8 WRITE !,?3,$PIECE(Y0,U),?35,$PIECE(X0,U,2)
- +9 IF +$PIECE(X0,U,6)
- Begin DoDot:2
- +10 NEW Y
- SET Y=$PIECE(X0,U,6)
- XECUTE ^DD("DD")
- WRITE ?51,Y," to "
- End DoDot:2
- +11 IF +$PIECE(X0,U,7)
- Begin DoDot:2
- +12 NEW Y
- SET Y=$PIECE(X0,U,7)
- XECUTE ^DD("DD")
- WRITE ?66,Y
- End DoDot:2
- End DoDot:1
- +13 QUIT
- +14 ;
- MCR ;find medicare information
- +1 NEW X,Y,X0,Y0
- +2 IF '$DATA(^AUPNMCR(DFN))
- Begin DoDot:1
- +3 WRITE !," *** NO MEDICARE INFORMATION ON RECORD ***"
- End DoDot:1
- QUIT
- +4 DO MCR1
- SET X0=^AUPNMCR(DFN,0)
- Begin DoDot:1
- +5 ;medicare number
- SET Y=$PIECE(X0,U,3)
- IF 'Y
- QUIT
- WRITE !,?3,Y
- +6 SET Y=$PIECE(X0,U,4)
- IF 'Y!('$DATA(^AUTTMCS(+Y,0)))
- QUIT
- SET Y0=^(0)
- WRITE ?14,Y0
- End DoDot:1
- +7 WRITE ?21,$$VAL^XBDIQ1(9000001,DFN,.04)
- +8 SET X=0
- +9 FOR
- SET X=$ORDER(^AUPNMCR(DFN,11,X))
- IF 'X
- QUIT
- Begin DoDot:1
- +10 IF '$DATA(^AUPNMCR(DFN,11,X,0))
- QUIT
- SET X0=^(0)
- +11 IF $PIECE(X0,U)
- Begin DoDot:2
- +12 NEW Y
- SET Y=$PIECE(X0,U)
- XECUTE ^DD("DD")
- WRITE ?35,Y," to "
- End DoDot:2
- +13 IF $PIECE(X0,U,2)
- Begin DoDot:2
- +14 NEW Y
- SET Y=$PIECE(X0,U,2)
- XECUTE ^DD("DD")
- WRITE ?50,Y
- End DoDot:2
- +15 IF $PIECE(X0,U,3)'=""
- Begin DoDot:2
- +16 NEW Y
- SET Y=$PIECE(X0,U,3)
- WRITE ?65,Y
- End DoDot:2
- +17 WRITE !
- End DoDot:1
- +18 QUIT
- +19 ;
- MCD ;find medicaid information
- +1 ;
- +2 NEW X,Y,Z,X0,Y0,IFN
- +3 IF '$DATA(^AUPNMCD("B",DFN))
- Begin DoDot:1
- +4 WRITE !," *** NO MEDICAID INFORMATION ON RECORD ***"
- End DoDot:1
- QUIT
- +5 DO MCD1
- SET IFN=0
- FOR
- SET IFN=$ORDER(^AUPNMCD("B",DFN,IFN))
- IF IFN=""
- QUIT
- Begin DoDot:1
- +6 SET X0=^AUPNMCD(IFN,0)
- Begin DoDot:2
- +7 ;medicaid number
- SET Y=$PIECE(X0,U,3)
- WRITE !,?3,Y
- +8 SET Y=$PIECE(X0,U,4)
- IF 'Y!('$DATA(^DIC(5,+Y,0)))
- QUIT
- SET Y0=$PIECE(^(0),U,2)
- WRITE ?14,Y0
- +9 SET Y=$SELECT($PIECE(X0,U,8):$PIECE(X0,U,8),1:"")
- IF 'Y
- QUIT
- XECUTE ^DD("DD")
- SET Z=Y
- End DoDot:2
- +10 SET X=0
- FOR
- SET X=$ORDER(^AUPNMCD(IFN,11,X))
- IF 'X
- QUIT
- Begin DoDot:2
- +11 IF '$DATA(^AUPNMCD(IFN,11,X,0))
- QUIT
- SET X0=^(0)
- +12 IF $PIECE(X0,U)
- Begin DoDot:3
- +13 NEW Y
- SET Y=$PIECE(X0,U)
- XECUTE ^DD("DD")
- WRITE ?35,Y," to "
- End DoDot:3
- +14 IF $PIECE(X0,U,2)
- Begin DoDot:3
- +15 NEW Y
- SET Y=$PIECE(X0,U,2)
- XECUTE ^DD("DD")
- WRITE ?50,Y
- End DoDot:3
- +16 IF $PIECE(X0,U,3)'=""
- Begin DoDot:3
- +17 NEW Y
- SET Y=$PIECE(X0,U,3)
- WRITE ?65,Y
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +18 IF $GET(Z)
- WRITE !!,?3,"Medicaid date of last update: ",Z,!
- +19 QUIT
- +20 ;
- PRT2 ;print request for current information
- +1 NEW X,Y
- +2 WRITE !!,?3,"Does this include Dental coverage? Yes___ No___"
- +3 WRITE !!,?3,"Is this a work related Injury? Yes___ No___",!
- +4 WRITE ?3,"Date of Injury: _______________________"
- +5 WRITE !!,?8,"We appreciate your cooperation and assistance in filling"
- +6 WRITE " out this form."
- +7 WRITE !,?3,"It is important that we keep our patient registration"
- +8 WRITE " files accurate so"
- +9 WRITE !,?3,"that we can provide a better service to you."
- +10 WRITE !!,?3,"The Business Office, ",SITE,?50,"Printed at "
- +11 DO TIME^ASDUT
- WRITE " "
- DO ^%D
- +12 QUIT
- +13 ;
- +14 ;
- PARENT ; -- parents' birth info
- +1 IF FMBIRTH=""
- SET (MCBIRTH,MSBIRTH,FCBIRTH,FSBIRTH)=" "
- QUIT
- +2 SET MCBIRTH=$PIECE($GET(FMBIRTH),U,5)
- SET MSBIRTHP=$PIECE($GET(FMBIRTH),U,6)
- +3 SET MSBIRTH=$PIECE($GET(^DIC(5,+MSBIRTHP,0)),U,2)
- SET FCBIRTH=$PIECE($GET(FMBIRTH),U,2)
- +4 SET FSBIRTHP=$PIECE($GET(FMBIRTH),U,3)
- SET FSBIRTH=$PIECE($GET(^DIC(5,+FSBIRTHP,0)),U,2)
- +5 QUIT
- EMPY ; -- employer name
- +1 SET EMPY=$PIECE($GET(PNODE),U,19)
- IF EMPY=""
- SET EMPY="NONE"
- QUIT
- +2 SET EMPY=$PIECE($GET(^AUTNEMPL(EMPY,0)),U)
- QUIT
- +3 ;
- SEMPY ; -- spouse employer
- +1 NEW Y
- SET SEMPYP=$PIECE($GET(PNODE),U,22)
- IF SEMPYP=""
- SET SEMPY="NONE"
- QUIT
- +2 SET SEMPY=$PIECE($GET(^AUTNEMPL(SEMPYP,0)),U)
- +3 QUIT
- +4 ;
- AGE() ; -- get the printable age
- +1 NEW DA
- +2 SET DA=DFN
- +3 ;S DR=1102.98,DIC=9000001 D ^AUDICLK ;IHS/DSD/ENM 01/22/99
- +4 ;IHS/DSD/ENM 01/22/99
- SET DR=1102.98
- SET DIC=9000001
- DO ^ASDZAGE
- +5 SET AGE=$SELECT($DATA(LKPRINT):LKPRINT,1:"")
- +6 QUIT AGE
- +7 ;
