- APCHS1B ; IHS/CMI/LAB - PART 1 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
- ;;2.0;IHS PCC SUITE;**5,10,11**;MAY 14, 2009;Build 58
- ;
- DEMOG ; ******************** DEMOGRAPHICS ********************
- ; <SETUP>
- S APCHSN=^DPT(APCHSPAT,0)
- S APCHSNAM=$P(APCHSN,U,1)
- S APCHSEX=$P(APCHSN,U,2),APCHSEX=$S(APCHSEX="M":"MALE",APCHSEX="F":"FEMALE",APCHSEX="U":"UNKNOWN",1:"<no sex>")
- S Y=$P(APCHSN,U,3)
- I 'Y S APCHSDOB="<NO DATE OF BIRTH>"
- E X ^DD("DD") S APCHSDOB=Y
- S APCHSSN=$$SSN^APCHS1(APCHSPAT) ;$P(APCHSN,U,9) S:APCHSSN]"" APCHSSN=$E(APCHSSN,1,3)_"-"_$E(APCHSSN,4,5)_"-"_$E(APCHSSN,6,9)
- S APCHSN=$G(^DPT(APCHSPAT,.24))
- S APCHSMNM=$P(APCHSN,U,3)
- S APCHSFNM=$P(APCHSN,U)
- S APCHSN=^AUPNPAT(APCHSPAT,0)
- S Y=$P(APCHSN,U,3)
- I 'Y S APCHSLUD=""
- E X ^DD("DD") S APCHSLUD=Y
- S APCHSBT=$P(APCHSN,U,13) S:APCHSBT="" APCHSBT="no blood type"
- ;S APCHSPP=$P(APCHSN,U,14) S:APCHSPP="" APCHSPP="<none identified>" I +APCHSPP S APCHSPP=$P(^DIC(6,+APCHSPP,0),U,1) I +APCHSPP S APCHSPP=$P(^DIC(16,+APCHSPP,0),U,1) ;*** file 200 conversion ***
- S APCHSPP=$P(APCHSN,U,14)
- S:APCHSPP=-1 APCHSPP="" ;IHS/ANMC/LJF 8/5/99 prevent UNDEF
- S:APCHSPP="" APCHSPP="<none identified>"
- I +APCHSPP,$P(^DD(9000001,.14,0),U,2)[200 S APCHSPP=$P(^VA(200,APCHSPP,0),U) ;*** file 200 conversion ***
- I +APCHSPP S APCHSPP=$P(^DIC(6,+APCHSPP,0),U,1) I +APCHSPP S APCHSPP=$P(^DIC(16,+APCHSPP,0),U,1)
- V ;
- S APCHSVST="" I $D(^DPT(APCHSPAT,"VET"))#2,$P(^("VET"),U)="Y" D VSTAT
- S APCHSN=$G(^AUPNPAT(APCHSPAT,11))
- S APCHSTR=$P(APCHSN,U,8)
- I 'APCHSTR S APCHSTR="<no tribe>"
- E S APCHSTR=^AUTTTRI(APCHSTR,0) S APCHSTR=$P(APCHSTR,U,1)_$S($P(APCHSTR,U,4)="Y":" <old code>",1:"")
- S APCHSEL=$P(APCHSN,U,12)
- S X=$P(^DD(9000001,1112,0),U,3) F APCHSI=1:1 S APCHSP=$P(X,";",APCHSI) Q:APCHSP="" I $P(APCHSP,":",1)=APCHSEL S APCHSEL=$P(APCHSP,":",2) Q
- S APCHSCMR=$P(APCHSN,U,18) S:APCHSCMR="" APCHSCMR="<NO COMMUNITY OF RESIDENCE>"
- S APCHSI=$O(^AUPNPAT(APCHSPAT,13,0)) S APCHSRE1=$S(APCHSI:^(APCHSI,0),1:"") S APCHSI=$O(^AUPNPAT(APCHSPAT,13,APCHSI)) S APCHSRE2=$S(APCHSI:^(APCHSI,0),1:"") S:$O(^AUPNPAT(APCHSPAT,13,APCHSI)) APCHSRE2=APCHSRE2_" [more]"
- S APCHSADR=""
- I $D(^DPT(APCHSPAT,.11)) S APCHSN=^(.11) F E=1:1:6 S APCHSP=$P(APCHSN,U,E) I APCHSP]"" S:E=5 APCHSP=$P(^DIC(5,APCHSP,0),U,2) S APCHSADR=APCHSADR_","_APCHSP
- S APCHSADR=$E(APCHSADR,2,255)
- S:APCHSADR]"" APCHSCMR=APCHSCMR_" ("_APCHSADR_") "
- S APCHSN=$G(^DPT(APCHSPAT,.13))
- S APCHSHPH=$P(APCHSN,U,1),APCHSOPH=$P(APCHSN,U,2)
- I APCHSHPH="",APCHSOPH="" S APCHSHPH="<no phone numbers recorded>"
- S:+APCHSHPH APCHSHPH="(H) "_APCHSHPH
- S:APCHSOPH]"" APCHSOPH="(W) "_APCHSOPH S:APCHSHPH]"" APCHSOPH=" "_APCHSOPH
- G DEMDSP
- VSTAT S APCHSVST="VETERAN"
- I $D(^DPT(APCHSPAT,.3))#2,$P(^(.3),U)="Y" S APCHSVST="SERVICE-CONNECTED "_APCHSVST
- S APCHSN=$G(^DPT(APCHSPAT,.32))
- I $P(APCHSN,U,5) S APCHSVST=APCHSVST_" "_$P(^DIC(23,$P(APCHSN,U,5),0),U,2)
- S Y=$P(APCHSN,U,6) I Y D VSDT S APCHSVST=APCHSVST_" ("_Y_"-" S Y=$P(APCHSN,U,7) S:'Y APCHSVST=APCHSVST_"?)" I Y D VSDT S APCHSVST=APCHSVST_Y_")"
- I $D(^DPT(APCHSPAT,.31))#2 S APCHSN=^(.31) S Y=$P(APCHSN,U,3) I Y S APCHSVST=APCHSVST_" CLAIM# "_Y
- Q
- VSDT S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+$E(Y,1,3))
- Q
- DEMDSP ; <DISPLAY>
- X APCHSBRK
- I $$DOD^AUPNPAT(APCHSPAT)]""!($$VAL^XBDIQ1(9000001,APCHSPAT,1114)]"") D
- .W "*** DOD: ",$$VAL^XBDIQ1(2,APCHSPAT,.351),!
- .W "*** CAUSE OF DEATH: " I $$VAL^XBDIQ1(9000001,APCHSPAT,1114)]"" D I 1
- ..W $$VAL^XBDIQ1(9000001,APCHSPAT,1114)
- ..K APCHSDSC
- ..S APCHSDSC=$$ICDD^AUPNVUTL($$VAL^XBDIQ1(9000001,APCHSPAT,1114),"APCHSDSC",$$DOD^AUPNPAT(APCHSPAT)) I $P(APCHSDSC,U)=-1 S APCHSDSC(1)=$P($$ICDDX^ICDEX($P(^AUPNPAT(APCHSPAT,11),U,14),$$DOD^AUPNPAT(APCHSPAT)),U,4)
- ..K ^UTILITY($J,"W")
- ..S APCHSX=0
- ..S DIWL=0,DIWR=45 F S APCHSX=$O(APCHSDSC(APCHSX)) Q:APCHSX'=+APCHSX!($D(APCHSQIT)) D
- ...S X=APCHSDSC(APCHSX)
- ...Q:X="CODE TEXT MAY BE INACCURATE"
- ...Q:X=" "
- ...D ^DIWP
- ..S APCHSZ=0 F S APCHSZ=$O(^UTILITY($J,"W",DIWL,APCHSZ)) Q:APCHSZ'=+APCHSZ D
- ...X APCHSCKP Q:$D(APCHSQIT)
- ...W ?28,^UTILITY($J,"W",DIWL,APCHSZ,0),!
- .E W !!
- .;W !
- K ^UTILITY($J,"W"),APCHSDSC,DIWL,APCHSX,APCHSZ,DIWL,DIWR
- Q:$D(APCHSQIT)
- W APCHSNAM
- W:APCHSDOB]"" ?34,"DOB: ",APCHSDOB,?51,$$AGE(APCHSPAT,DT,"R")
- W:APCHSEX]"" ?59,APCHSEX
- W:APCHSBT]"" ?67,APCHSBT
- W !
- I APCHSTR]""!(APCHSMNM]"") W:APCHSTR]"" $E(APCHSTR,1,33) W:APCHSSN]"" ?34,"SSN: ",APCHSSN W !
- W:APCHSMNM]"" ?34,"MOTHER'S MAIDEN NAME: ",APCHSMNM W !
- W APCHSHPH,APCHSOPH W:APCHSFNM]"" ?34,"FATHER'S NAME: ",APCHSFNM W !
- S APCHPLNG=$$PREFLANG^APCLAPI7(APCHSPAT,DT,"E")
- I APCHPLNG]"" W ?34,"PREFERRED LANGUAGE: ",APCHPLNG,!
- I APCHSCMR]"" W APCHSCMR,!!
- I APCHSLUD]""!(APCHSEL]"") W:APCHSLUD]"" "LAST UPDATED: ",APCHSLUD," " W:APCHSEL]"" ?34,"ELIGIBILITY: ",APCHSEL W !
- W:APCHSVST]"" APCHSVST,!
- I $P($G(^AUPNPAT(APCHSPAT,40)),U,2)]"" W !,"Preferred Method of Receiving Reminders: ",$$VAL^XBDIQ1(9000001,APCHSPAT,4002),!
- W !
- ;I $D(^AUPNPAT(APCHSPAT,41)) W "HEALTH RECORD NUMBERS:" F APCHSFP=0:0 S APCHSFP=$O(^AUPNPAT(APCHSPAT,41,APCHSFP)) Q:'APCHSFP S APCHSHRN=$P(^(APCHSFP,0),U,2),APCHSFAC=$P(^DIC(4,APCHSFP,0),U,1) W ?24,$E(1000000+APCHSHRN,2,7)," ",APCHSFAC,!
- ;W "DESIGNATED PROVIDER: ",APCHSPP,!
- ;I APCHSRE1]"" W "REMARKS:",?9,APCHSRE1,! W:APCHSRE2]"" ?9,APCHSRE2,!
- ;D DSPCMSRG
- ; <CLEANUP>
- DEMOGX K APCHSNAM,APCHSTR,APCHSEX,APCHSDOB,APCHSSN,APCHSMNM,APCHSCMR,APCHSEL,APCHSFP,APCHSFAC,APCHSHRN,APCHSBT,APCHSPP,APCHSADR,APCHSN,APCHSP,APCHSI,APCHSJ,APCHSHPH,APCHSOPH,APCHSVST,APCHSLUD,APCHSRE1,APCHSRE2,E,X,Y
- Q
- DSPCMSRG ; DISPLAY MEMBERSHIP IN CMS REGISTER
- D DSPCMSRG^APCHS
- Q
- AGE(DFN,D,F) ;EP - Given DFN, return Age.
- I '$G(DFN) Q -1
- I '$D(^DPT(DFN,0)) Q -1
- I $$DOB^AUPNPAT(DFN,"")<0 Q -1
- S:$G(D)="" D=DT
- S:$G(F)="" F="Y"
- NEW %
- S %=$$FMDIFF^XLFDT(D,$$DOB^AUPNPAT(DFN,""))
- S %1=%\365.25
- I F="Y" Q %1
- ;beginning Y2K fix
- ;Q $S(%1>2:%1_" YRS",%<31:%1_" DYS",1:%\30_" MOS") ;Y2000
- Q $S(%1>2:%1_" YRS",%<31:%_" DYS",1:%\30_" MOS") ;Y2000
- ;end Y2K
- ;
- APCHS1B ; IHS/CMI/LAB - PART 1 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
- +1 ;;2.0;IHS PCC SUITE;**5,10,11**;MAY 14, 2009;Build 58
- +2 ;
- DEMOG ; ******************** DEMOGRAPHICS ********************
- +1 ; <SETUP>
- +2 SET APCHSN=^DPT(APCHSPAT,0)
- +3 SET APCHSNAM=$PIECE(APCHSN,U,1)
- +4 SET APCHSEX=$PIECE(APCHSN,U,2)
- SET APCHSEX=$SELECT(APCHSEX="M":"MALE",APCHSEX="F":"FEMALE",APCHSEX="U":"UNKNOWN",1:"<no sex>")
- +5 SET Y=$PIECE(APCHSN,U,3)
- +6 IF 'Y
- SET APCHSDOB="<NO DATE OF BIRTH>"
- +7 IF '$TEST
- XECUTE ^DD("DD")
- SET APCHSDOB=Y
- +8 ;$P(APCHSN,U,9) S:APCHSSN]"" APCHSSN=$E(APCHSSN,1,3)_"-"_$E(APCHSSN,4,5)_"-"_$E(APCHSSN,6,9)
- SET APCHSSN=$$SSN^APCHS1(APCHSPAT)
- +9 SET APCHSN=$GET(^DPT(APCHSPAT,.24))
- +10 SET APCHSMNM=$PIECE(APCHSN,U,3)
- +11 SET APCHSFNM=$PIECE(APCHSN,U)
- +12 SET APCHSN=^AUPNPAT(APCHSPAT,0)
- +13 SET Y=$PIECE(APCHSN,U,3)
- +14 IF 'Y
- SET APCHSLUD=""
- +15 IF '$TEST
- XECUTE ^DD("DD")
- SET APCHSLUD=Y
- +16 SET APCHSBT=$PIECE(APCHSN,U,13)
- IF APCHSBT=""
- SET APCHSBT="no blood type"
- +17 ;S APCHSPP=$P(APCHSN,U,14) S:APCHSPP="" APCHSPP="<none identified>" I +APCHSPP S APCHSPP=$P(^DIC(6,+APCHSPP,0),U,1) I +APCHSPP S APCHSPP=$P(^DIC(16,+APCHSPP,0),U,1) ;*** file 200 conversion ***
- +18 SET APCHSPP=$PIECE(APCHSN,U,14)
- +19 ;IHS/ANMC/LJF 8/5/99 prevent UNDEF
- IF APCHSPP=-1
- SET APCHSPP=""
- +20 IF APCHSPP=""
- SET APCHSPP="<none identified>"
- +21 ;*** file 200 conversion ***
- IF +APCHSPP
- IF $PIECE(^DD(9000001,.14,0),U,2)[200
- SET APCHSPP=$PIECE(^VA(200,APCHSPP,0),U)
- +22 IF +APCHSPP
- SET APCHSPP=$PIECE(^DIC(6,+APCHSPP,0),U,1)
- IF +APCHSPP
- SET APCHSPP=$PIECE(^DIC(16,+APCHSPP,0),U,1)
- V ;
- +1 SET APCHSVST=""
- IF $DATA(^DPT(APCHSPAT,"VET"))#2
- IF $PIECE(^("VET"),U)="Y"
- DO VSTAT
- +2 SET APCHSN=$GET(^AUPNPAT(APCHSPAT,11))
- +3 SET APCHSTR=$PIECE(APCHSN,U,8)
- +4 IF 'APCHSTR
- SET APCHSTR="<no tribe>"
- +5 IF '$TEST
- SET APCHSTR=^AUTTTRI(APCHSTR,0)
- SET APCHSTR=$PIECE(APCHSTR,U,1)_$SELECT($PIECE(APCHSTR,U,4)="Y":" <old code>",1:"")
- +6 SET APCHSEL=$PIECE(APCHSN,U,12)
- +7 SET X=$PIECE(^DD(9000001,1112,0),U,3)
- FOR APCHSI=1:1
- SET APCHSP=$PIECE(X,";",APCHSI)
- IF APCHSP=""
- QUIT
- IF $PIECE(APCHSP,":",1)=APCHSEL
- SET APCHSEL=$PIECE(APCHSP,":",2)
- QUIT
- +8 SET APCHSCMR=$PIECE(APCHSN,U,18)
- IF APCHSCMR=""
- SET APCHSCMR="<NO COMMUNITY OF RESIDENCE>"
- +9 SET APCHSI=$ORDER(^AUPNPAT(APCHSPAT,13,0))
- SET APCHSRE1=$SELECT(APCHSI:^(APCHSI,0),1:"")
- SET APCHSI=$ORDER(^AUPNPAT(APCHSPAT,13,APCHSI))
- SET APCHSRE2=$SELECT(APCHSI:^(APCHSI,0),1:"")
- IF $ORDER(^AUPNPAT(APCHSPAT,13,APCHSI))
- SET APCHSRE2=APCHSRE2_" [more]"
- +10 SET APCHSADR=""
- +11 IF $DATA(^DPT(APCHSPAT,.11))
- SET APCHSN=^(.11)
- FOR E=1:1:6
- SET APCHSP=$PIECE(APCHSN,U,E)
- IF APCHSP]""
- IF E=5
- SET APCHSP=$PIECE(^DIC(5,APCHSP,0),U,2)
- SET APCHSADR=APCHSADR_","_APCHSP
- +12 SET APCHSADR=$EXTRACT(APCHSADR,2,255)
- +13 IF APCHSADR]""
- SET APCHSCMR=APCHSCMR_" ("_APCHSADR_") "
- +14 SET APCHSN=$GET(^DPT(APCHSPAT,.13))
- +15 SET APCHSHPH=$PIECE(APCHSN,U,1)
- SET APCHSOPH=$PIECE(APCHSN,U,2)
- +16 IF APCHSHPH=""
- IF APCHSOPH=""
- SET APCHSHPH="<no phone numbers recorded>"
- +17 IF +APCHSHPH
- SET APCHSHPH="(H) "_APCHSHPH
- +18 IF APCHSOPH]""
- SET APCHSOPH="(W) "_APCHSOPH
- IF APCHSHPH]""
- SET APCHSOPH=" "_APCHSOPH
- +19 GOTO DEMDSP
- VSTAT SET APCHSVST="VETERAN"
- +1 IF $DATA(^DPT(APCHSPAT,.3))#2
- IF $PIECE(^(.3),U)="Y"
- SET APCHSVST="SERVICE-CONNECTED "_APCHSVST
- +2 SET APCHSN=$GET(^DPT(APCHSPAT,.32))
- +3 IF $PIECE(APCHSN,U,5)
- SET APCHSVST=APCHSVST_" "_$PIECE(^DIC(23,$PIECE(APCHSN,U,5),0),U,2)
- +4 SET Y=$PIECE(APCHSN,U,6)
- IF Y
- DO VSDT
- SET APCHSVST=APCHSVST_" ("_Y_"-"
- SET Y=$PIECE(APCHSN,U,7)
- IF 'Y
- SET APCHSVST=APCHSVST_"?)"
- IF Y
- DO VSDT
- SET APCHSVST=APCHSVST_Y_")"
- +5 IF $DATA(^DPT(APCHSPAT,.31))#2
- SET APCHSN=^(.31)
- SET Y=$PIECE(APCHSN,U,3)
- IF Y
- SET APCHSVST=APCHSVST_" CLAIM# "_Y
- +6 QUIT
- VSDT SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_(1700+$EXTRACT(Y,1,3))
- +1 QUIT
- DEMDSP ; <DISPLAY>
- +1 XECUTE APCHSBRK
- +2 IF $$DOD^AUPNPAT(APCHSPAT)]""!($$VAL^XBDIQ1(9000001,APCHSPAT,1114)]"")
- Begin DoDot:1
- +3 WRITE "*** DOD: ",$$VAL^XBDIQ1(2,APCHSPAT,.351),!
- +4 WRITE "*** CAUSE OF DEATH: "
- IF $$VAL^XBDIQ1(9000001,APCHSPAT,1114)]""
- Begin DoDot:2
- +5 WRITE $$VAL^XBDIQ1(9000001,APCHSPAT,1114)
- +6 KILL APCHSDSC
- +7 SET APCHSDSC=$$ICDD^AUPNVUTL($$VAL^XBDIQ1(9000001,APCHSPAT,1114),"APCHSDSC",$$DOD^AUPNPAT(APCHSPAT))
- IF $PIECE(APCHSDSC,U)=-1
- SET APCHSDSC(1)=$PIECE($$ICDDX^ICDEX($PIECE(^AUPNPAT(APCHSPAT,11),U,14),$$DOD^AUPNPAT(APCHSPAT)),U,4)
- +8 KILL ^UTILITY($JOB,"W")
- +9 SET APCHSX=0
- +10 SET DIWL=0
- SET DIWR=45
- FOR
- SET APCHSX=$ORDER(APCHSDSC(APCHSX))
- IF APCHSX'=+APCHSX!($DATA(APCHSQIT))
- QUIT
- Begin DoDot:3
- +11 SET X=APCHSDSC(APCHSX)
- +12 IF X="CODE TEXT MAY BE INACCURATE"
- QUIT
- +13 IF X=" "
- QUIT
- +14 DO ^DIWP
- End DoDot:3
- +15 SET APCHSZ=0
- FOR
- SET APCHSZ=$ORDER(^UTILITY($JOB,"W",DIWL,APCHSZ))
- IF APCHSZ'=+APCHSZ
- QUIT
- Begin DoDot:3
- +16 XECUTE APCHSCKP
- IF $DATA(APCHSQIT)
- QUIT
- +17 WRITE ?28,^UTILITY($JOB,"W",DIWL,APCHSZ,0),!
- End DoDot:3
- End DoDot:2
- IF 1
- +18 IF '$TEST
- WRITE !!
- +19 ;W !
- End DoDot:1
- +20 KILL ^UTILITY($JOB,"W"),APCHSDSC,DIWL,APCHSX,APCHSZ,DIWL,DIWR
- +21 IF $DATA(APCHSQIT)
- QUIT
- +22 WRITE APCHSNAM
- +23 IF APCHSDOB]""
- WRITE ?34,"DOB: ",APCHSDOB,?51,$$AGE(APCHSPAT,DT,"R")
- +24 IF APCHSEX]""
- WRITE ?59,APCHSEX
- +25 IF APCHSBT]""
- WRITE ?67,APCHSBT
- +26 WRITE !
- +27 IF APCHSTR]""!(APCHSMNM]"")
- IF APCHSTR]""
- WRITE $EXTRACT(APCHSTR,1,33)
- IF APCHSSN]""
- WRITE ?34,"SSN: ",APCHSSN
- WRITE !
- +28 IF APCHSMNM]""
- WRITE ?34,"MOTHER'S MAIDEN NAME: ",APCHSMNM
- WRITE !
- +29 WRITE APCHSHPH,APCHSOPH
- IF APCHSFNM]""
- WRITE ?34,"FATHER'S NAME: ",APCHSFNM
- WRITE !
- +30 SET APCHPLNG=$$PREFLANG^APCLAPI7(APCHSPAT,DT,"E")
- +31 IF APCHPLNG]""
- WRITE ?34,"PREFERRED LANGUAGE: ",APCHPLNG,!
- +32 IF APCHSCMR]""
- WRITE APCHSCMR,!!
- +33 IF APCHSLUD]""!(APCHSEL]"")
- IF APCHSLUD]""
- WRITE "LAST UPDATED: ",APCHSLUD," "
- IF APCHSEL]""
- WRITE ?34,"ELIGIBILITY: ",APCHSEL
- WRITE !
- +34 IF APCHSVST]""
- WRITE APCHSVST,!
- +35 IF $PIECE($GET(^AUPNPAT(APCHSPAT,40)),U,2)]""
- WRITE !,"Preferred Method of Receiving Reminders: ",$$VAL^XBDIQ1(9000001,APCHSPAT,4002),!
- +36 WRITE !
- +37 ;I $D(^AUPNPAT(APCHSPAT,41)) W "HEALTH RECORD NUMBERS:" F APCHSFP=0:0 S APCHSFP=$O(^AUPNPAT(APCHSPAT,41,APCHSFP)) Q:'APCHSFP S APCHSHRN=$P(^(APCHSFP,0),U,2),APCHSFAC=$P(^DIC(4,APCHSFP,0),U,1) W ?24,$E(1000000+APCHSHRN,2,7)," ",APCHSFAC,!
- +38 ;W "DESIGNATED PROVIDER: ",APCHSPP,!
- +39 ;I APCHSRE1]"" W "REMARKS:",?9,APCHSRE1,! W:APCHSRE2]"" ?9,APCHSRE2,!
- +40 ;D DSPCMSRG
- +41 ; <CLEANUP>
- DEMOGX KILL APCHSNAM,APCHSTR,APCHSEX,APCHSDOB,APCHSSN,APCHSMNM,APCHSCMR,APCHSEL,APCHSFP,APCHSFAC,APCHSHRN,APCHSBT,APCHSPP,APCHSADR,APCHSN,APCHSP,APCHSI,APCHSJ,APCHSHPH,APCHSOPH,APCHSVST,APCHSLUD,APCHSRE1,APCHSRE2,E,X,Y
- +1 QUIT
- DSPCMSRG ; DISPLAY MEMBERSHIP IN CMS REGISTER
- +1 DO DSPCMSRG^APCHS
- +2 QUIT
- AGE(DFN,D,F) ;EP - Given DFN, return Age.
- +1 IF '$GET(DFN)
- QUIT -1
- +2 IF '$DATA(^DPT(DFN,0))
- QUIT -1
- +3 IF $$DOB^AUPNPAT(DFN,"")<0
- QUIT -1
- +4 IF $GET(D)=""
- SET D=DT
- +5 IF $GET(F)=""
- SET F="Y"
- +6 NEW %
- +7 SET %=$$FMDIFF^XLFDT(D,$$DOB^AUPNPAT(DFN,""))
- +8 SET %1=%\365.25
- +9 IF F="Y"
- QUIT %1
- +10 ;beginning Y2K fix
- +11 ;Q $S(%1>2:%1_" YRS",%<31:%1_" DYS",1:%\30_" MOS") ;Y2000
- +12 ;Y2000
- QUIT $SELECT(%1>2:%1_" YRS",%<31:%_" DYS",1:%\30_" MOS")
- +13 ;end Y2K
- +14 ;