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 ;
