APCHS1 ; IHS/CMI/LAB - PART 1 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**2,5,10,11**;MAY 14, 2009;Build 58
;CMI/TUCSON/LAB - patch 2 fix age display
;IHS/CMI/LAB - patch 11, added check for LR nodes to prevent undef
; patch 11, added Notice of Privacy Act data per Shirley Lujan email
;IHS/CMI/LAB - patch 12 added chronic pain registry data per ANMC
;
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(APCHSPAT)
;S APCHSSN=$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"
; start - vjm 9/20/01 logic for Blood Bank blood type
; 1) use BB's ABO/Rh - if it exists
; 2) use PCC blood type - if it exists
; 3) otherwise, say 'no blood type'
;S APCHSBT=$P(APCHSN,U,13) S:APCHSBT="" APCHSBT="no blood type"
D
. Q:'$D(^DPT(APCHSPAT,"LR"))
. S APCHX("LRDFN")=^DPT(APCHSPAT,"LR") ; get pt's LRDFN
. D ; get Blood Bank blood type
.. Q:'$D(APCHX("LRDFN"))
.. Q:APCHX("LRDFN")=""
.. Q:'$D(^LR(APCHX("LRDFN"),0))
.. S APCHX("LR")=^LR(APCHX("LRDFN"),0)
.. S APCHX("ABO")=$P($G(APCHX("LR")),U,5)
.. Q:APCHX("ABO")=""
.. S APCHX("Rh")=$P($G(APCHX("LR")),U,6)
.. Q:APCHX("Rh")=""
.. S APCHX("ABO/Rh")=APCHX("ABO")_"/"_APCHX("Rh")
.. S:$D(APCHX("ABO/Rh")) APCHSBT="ABO/Rh: "_APCHX("ABO/Rh")
.. Q
. Q
I '$D(APCHX("ABO/Rh")) D ; no BB data - data from ^DPT BType
. S APCHSBT=$P(APCHSN,U,13)
. S:APCHSBT="" APCHSBT="no blood type"
. Q
K APCHX ; kill APCHX vars
; end - vjm 9/20/01
;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,$P(^DD(9000001,.14,0),U,2)[6 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 APCHSNL=$P($G(^APCHSITE(DUZ(2),0)),U,4)
S APCHSFLD=$P($G(^APCHSITE(DUZ(2),0)),U,5)
I 'APCHSNL S APCHSNL=2
I APCHSFLD="" S APCHSFLD="F"
K APCHSRE1
S C=0,APCHTCNT=0
S X=0 F S X=$O(^AUPNPAT(APCHSPAT,13,X)) Q:X'=+X S APCHTCNT=APCHTCNT+1
I APCHSFLD="F" S X=0 F S X=$O(^AUPNPAT(APCHSPAT,13,X)) Q:X'=+X!(C=APCHSNL) S C=C+1,APCHSRE1(C)=^AUPNPAT(APCHSPAT,13,X,0)
I APCHSFLD="L" S X=9999999 F S X=$O(^AUPNPAT(APCHSPAT,13,X),-1) Q:X<1!(C=APCHSNL) S C=C+1,APCHSRE1(99999-C)=^AUPNPAT(APCHSPAT,13,X,0)
;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($G(^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
S APCHOTPH=$P($G(^AUPNPAT(APCHSPAT,18)),U,1)
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
; start - vjm 9/20/2001 - to accomodate the display of ABO/Rh
;W:APCHSBT]"" ?67,APCHSBT
;W !
D
. I APCHSBT["/" W !,?34,APCHSBT,! Q
. W:APCHSBT]"" ?67,APCHSBT,!
. Q
; end - vjm 9/20/2001
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")
D
.I APCHOTPH]"" W "OTHER PHONE: ",APCHOTPH
.I APCHPLNG]"" W ?34,"PREFERRED LANGUAGE: ",APCHPLNG
.I APCHOTPH]""!(APCHPLNG)]"" W !
I APCHSCMR]"" W APCHSCMR,!!
I APCHSLUD]""!(APCHSEL]"") W:APCHSLUD]"" "LAST UPDATED: ",APCHSLUD," " W:APCHSEL]"" ?34,"ELIGIBILITY: ",APCHSEL W !
W:APCHSVST]"" APCHSVST,!
;IHS/CMI/LAB - patch 11 added Notice of Privacy act display
S APCHSNPP=$G(^AUPNNPP(APCHSPAT,0))
W !,"NOTICE OF PRIVACY PRACTICES REC'D BY PATIENT? ",$$VAL^XBDIQ1(9000038,APCHSPAT,.02)
W !," DATE RECEIVED BY PATIENT: ",$$FMTE^XLFDT($P(APCHSNPP,U,3))
W !," WAS ACKNOWLEDGEMENT SIGNED? ",$$VAL^XBDIQ1(9000038,APCHSPAT,.04)
I $P(APCHSNPP,U,5)]"" D
.W !," REASON: ",$P(APCHSNPP,U,5)
W !
K APCHSNPP
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,!
X APCHSCKP Q:$D(APCHSQIT)
I $O(^BDPRECN("C",APCHSPAT,0)) D BDPDISP G REM
W "DESIGNATED PRIMARY CARE PROVIDER: ",APCHSPP,!
REM ;
;IHS/ANMC/LAB - added next 3 lines per Mosley 2/12/01
I $P($G(^BWP(APCHSPAT,0)),U,25) S A="WOMEN'S HEALTH DESIGNATED PROVIDER" W ?(38-$L(A)),A,": "_$$VAL^XBDIQ1(9002086,APCHSPAT,.25),!
I $P($G(^AUPNPAT(APCHSPAT,17)),U,1) S A="PRIMARY MENTAL HEALTH PROVIDER" W ?(38-$L(A)),A,": ",$E($$VAL^XBDIQ1(9000001,APCHSPAT,1701),1,22),!
I $P($G(^AUPNPAT(APCHSPAT,17)),U,4) S A="SECONDARY MENTAL HEALTH PROVIDER" W ?(38-$L(A)),A,": ",$$VAL^XBDIQ1(9000001,APCHSPAT,1704),!
;I APCHSRE1]"" W "REMARKS:",?9,APCHSRE1,! W:APCHSRE2]"" ?9,APCHSRE2,!
I $D(APCHSRE1) W "REMARKS:",! D
.S APCHSX=0 F S APCHSX=$O(APCHSRE1(APCHSX)) Q:APCHSX=""!($D(APCHSQIT)) D
..X APCHSCKP Q:$D(APCHSQIT)
..W ?1,APCHSRE1(APCHSX),!
I APCHSNL<APCHTCNT W ?1,"[more]",!
I $D(^BCPP(APCHSPAT)) D ;IHS/ANMC/LAB
.S X="BCPAPI" X ^%ZOSF("TEST") I '$T Q
.W !,"CHRONIC PAIN REGISTRY STATUS: ",$$VAL^XBDIQ1(90246,APCHSPAT,.02) ;IHS/ANMC/LAB - added for chronic pain registry
.D ACTAGR^BCPAPI(.APCHAG,APCHSPAT,1) W ?45,$S(APCHAG:"Opioid Agreement",1:"No Opioid Agreement"),! ;IHS/ANMC/LAB
I $P($G(^AUPNPAT(APCHSPAT,40)),U,2)]"" W !,"Preferred Method of Receiving Reminders: ",$$VAL^XBDIQ1(9000001,APCHSPAT,4002),!
D DSPCMSRG
; CIA/PLS - 11/24/04 - WiseWoman Modification per Mike Mosley
;D WWDSPL(APCHSPAT) ; WW modification per Mike Mosley
; <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
K APCHSX,APCHSRE1,APCHSNL,APCHSFLD
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
;
BDPDISP ;EP - display providers from desg prov package
W ?30,"DESIGNATED PROVIDERS",!
S APCHSX=0 F S APCHSX=$O(^BDPRECN("C",APCHSPAT,APCHSX)) Q:APCHSX'=+APCHSX D
.X APCHSCKP Q:$D(APCHSQIT)
.;get category and check health summary status
.S A=$P($G(^BDPRECN(APCHSX,0)),U)
.Q:A=""
.Q:'$D(^BDPTCAT(A,0))
.Q:$P(^BDPTCAT(A,0),U,8)="N"
.S A=$$VAL^XBDIQ1(90360.1,APCHSX,.01) S:A="DESIGNATED PRIMARY PROVIDER" A="DESIGNATED PRIMARY CARE PROVIDER" W ?(38-$L(A)),A,": "_$$VAL^XBDIQ1(90360.1,APCHSX,.03),!
.Q
Q
WWDSPL(DFN) ;
N AGE,STAT,SDATE,WW
Q:$E(APCHSEX,1)'="F" "" ; Must be a female patient
S STAT="",SDATE=0
S WW=$$WWENPROC(DFN)
I WW D
.S STAT="ENROLLED",SDATE=WW
E D
.S STAT=$$GET1^DIQ(9000001,DFN,1709)
.I $L(STAT) D
..S SDATE=$$GET1^DIQ(9000001,DFN,1710,"I")
.E D
..S AGE=$$AGE^AUPNPAT(DFN)
..S:AGE>29&(AGE<65) STAT="UNKNOWN"
I $L(STAT) D
.W !,"WW Status: ",STAT W:SDATE ?30,"WW Update Date: ",$$FMTE^XLFDT(SDATE)
.W !!
Q
; Return date of WW Enrollment Procedure or Zero
WWENPROC(DFN) ;
N IEN,PDT
S PDT=0
Q:'$G(DFN) PDT
S (IEN,PDT)=0 F S IEN=$O(^BWPCD("C",DFN,IEN)) Q:'IEN D
.I $$GET1^DIQ(9002086.1,IEN,4.01,"I")=1 D
..S PDT=+$$GET1^DIQ(9002086.1,IEN,4.02,"I")
Q PDT
SSN(P) ;EP
I '$G(P) Q ""
I '$D(^DPT(P,0)) Q ""
Q $S($L($P(^DPT(P,0),U,9))=9:$J("XXX-XX-"_$E($P(^DPT(P,0),U,9),6,9),11),1:$J($P(^DPT(P,0),U,9),11))
APCHS1 ; IHS/CMI/LAB - PART 1 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**2,5,10,11**;MAY 14, 2009;Build 58
+2 ;CMI/TUCSON/LAB - patch 2 fix age display
+3 ;IHS/CMI/LAB - patch 11, added check for LR nodes to prevent undef
+4 ; patch 11, added Notice of Privacy Act data per Shirley Lujan email
+5 ;IHS/CMI/LAB - patch 12 added chronic pain registry data per ANMC
+6 ;
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 SET APCHSSN=$$SSN(APCHSPAT)
+9 ;S APCHSSN=$P(APCHSN,U,9) S:APCHSSN]"" APCHSSN=$E(APCHSSN,1,3)_"-"_$E(APCHSSN,4,5)_"-"_$E(APCHSSN,6,9)
+10 SET APCHSN=$GET(^DPT(APCHSPAT,.24))
+11 SET APCHSMNM=$PIECE(APCHSN,U,3)
+12 SET APCHSFNM=$PIECE(APCHSN,U)
+13 SET APCHSN=^AUPNPAT(APCHSPAT,0)
+14 SET Y=$PIECE(APCHSN,U,3)
+15 IF 'Y
SET APCHSLUD=""
+16 IF '$TEST
XECUTE ^DD("DD")
SET APCHSLUD=Y
+17 ;S APCHSBT=$P(APCHSN,U,13) S:APCHSBT="" APCHSBT="no blood type"
+18 ; start - vjm 9/20/01 logic for Blood Bank blood type
+19 ; 1) use BB's ABO/Rh - if it exists
+20 ; 2) use PCC blood type - if it exists
+21 ; 3) otherwise, say 'no blood type'
+22 ;S APCHSBT=$P(APCHSN,U,13) S:APCHSBT="" APCHSBT="no blood type"
+23 Begin DoDot:1
+24 IF '$DATA(^DPT(APCHSPAT,"LR"))
QUIT
+25 ; get pt's LRDFN
SET APCHX("LRDFN")=^DPT(APCHSPAT,"LR")
+26 ; get Blood Bank blood type
Begin DoDot:2
+27 IF '$DATA(APCHX("LRDFN"))
QUIT
+28 IF APCHX("LRDFN")=""
QUIT
+29 IF '$DATA(^LR(APCHX("LRDFN"),0))
QUIT
+30 SET APCHX("LR")=^LR(APCHX("LRDFN"),0)
+31 SET APCHX("ABO")=$PIECE($GET(APCHX("LR")),U,5)
+32 IF APCHX("ABO")=""
QUIT
+33 SET APCHX("Rh")=$PIECE($GET(APCHX("LR")),U,6)
+34 IF APCHX("Rh")=""
QUIT
+35 SET APCHX("ABO/Rh")=APCHX("ABO")_"/"_APCHX("Rh")
+36 IF $DATA(APCHX("ABO/Rh"))
SET APCHSBT="ABO/Rh: "_APCHX("ABO/Rh")
+37 QUIT
End DoDot:2
+38 QUIT
End DoDot:1
+39 ; no BB data - data from ^DPT BType
IF '$DATA(APCHX("ABO/Rh"))
Begin DoDot:1
+40 SET APCHSBT=$PIECE(APCHSN,U,13)
+41 IF APCHSBT=""
SET APCHSBT="no blood type"
+42 QUIT
End DoDot:1
+43 ; kill APCHX vars
KILL APCHX
+44 ; end - vjm 9/20/01
+45 ;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 ***
+46 SET APCHSPP=$PIECE(APCHSN,U,14)
+47 ;IHS/ANMC/LJF 8/5/99 prevent UNDEF
IF APCHSPP=-1
SET APCHSPP=""
+48 IF APCHSPP=""
SET APCHSPP="<none identified>"
+49 ;*** file 200 conversion ***
IF +APCHSPP
IF $PIECE(^DD(9000001,.14,0),U,2)[200
SET APCHSPP=$PIECE(^VA(200,APCHSPP,0),U)
+50 IF +APCHSPP
IF $PIECE(^DD(9000001,.14,0),U,2)[6
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 APCHSNL=$PIECE($GET(^APCHSITE(DUZ(2),0)),U,4)
+10 SET APCHSFLD=$PIECE($GET(^APCHSITE(DUZ(2),0)),U,5)
+11 IF 'APCHSNL
SET APCHSNL=2
+12 IF APCHSFLD=""
SET APCHSFLD="F"
+13 KILL APCHSRE1
+14 SET C=0
SET APCHTCNT=0
+15 SET X=0
FOR
SET X=$ORDER(^AUPNPAT(APCHSPAT,13,X))
IF X'=+X
QUIT
SET APCHTCNT=APCHTCNT+1
+16 IF APCHSFLD="F"
SET X=0
FOR
SET X=$ORDER(^AUPNPAT(APCHSPAT,13,X))
IF X'=+X!(C=APCHSNL)
QUIT
SET C=C+1
SET APCHSRE1(C)=^AUPNPAT(APCHSPAT,13,X,0)
+17 IF APCHSFLD="L"
SET X=9999999
FOR
SET X=$ORDER(^AUPNPAT(APCHSPAT,13,X),-1)
IF X<1!(C=APCHSNL)
QUIT
SET C=C+1
SET APCHSRE1(99999-C)=^AUPNPAT(APCHSPAT,13,X,0)
+18 ;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]"
+19 SET APCHSADR=""
+20 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($GET(^DIC(5,APCHSP,0)),U,2)
SET APCHSADR=APCHSADR_","_APCHSP
+21 SET APCHSADR=$EXTRACT(APCHSADR,2,255)
+22 IF APCHSADR]""
SET APCHSCMR=APCHSCMR_" ("_APCHSADR_") "
+23 SET APCHSN=$GET(^DPT(APCHSPAT,.13))
+24 SET APCHSHPH=$PIECE(APCHSN,U,1)
SET APCHSOPH=$PIECE(APCHSN,U,2)
+25 IF APCHSHPH=""
IF APCHSOPH=""
SET APCHSHPH="<no phone numbers recorded>"
+26 IF +APCHSHPH
SET APCHSHPH="(H) "_APCHSHPH
+27 IF APCHSOPH]""
SET APCHSOPH="(W) "_APCHSOPH
IF APCHSHPH]""
SET APCHSOPH=" "_APCHSOPH
+28 SET APCHOTPH=$PIECE($GET(^AUPNPAT(APCHSPAT,18)),U,1)
+29 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 ; start - vjm 9/20/2001 - to accomodate the display of ABO/Rh
+26 ;W:APCHSBT]"" ?67,APCHSBT
+27 ;W !
+28 Begin DoDot:1
+29 IF APCHSBT["/"
WRITE !,?34,APCHSBT,!
QUIT
+30 IF APCHSBT]""
WRITE ?67,APCHSBT,!
+31 QUIT
End DoDot:1
+32 ; end - vjm 9/20/2001
+33 IF APCHSTR]""!(APCHSMNM]"")
IF APCHSTR]""
WRITE $EXTRACT(APCHSTR,1,33)
IF APCHSSN]""
WRITE ?34,"SSN: ",APCHSSN
WRITE !
+34 IF APCHSMNM]""
WRITE ?34,"MOTHER'S MAIDEN NAME: ",APCHSMNM
WRITE !
+35 WRITE APCHSHPH,APCHSOPH
IF APCHSFNM]""
WRITE ?34,"FATHER'S NAME: ",APCHSFNM
WRITE !
+36 SET APCHPLNG=$$PREFLANG^APCLAPI7(APCHSPAT,DT,"E")
+37 Begin DoDot:1
+38 IF APCHOTPH]""
WRITE "OTHER PHONE: ",APCHOTPH
+39 IF APCHPLNG]""
WRITE ?34,"PREFERRED LANGUAGE: ",APCHPLNG
+40 IF APCHOTPH]""!(APCHPLNG)]""
WRITE !
End DoDot:1
+41 IF APCHSCMR]""
WRITE APCHSCMR,!!
+42 IF APCHSLUD]""!(APCHSEL]"")
IF APCHSLUD]""
WRITE "LAST UPDATED: ",APCHSLUD," "
IF APCHSEL]""
WRITE ?34,"ELIGIBILITY: ",APCHSEL
WRITE !
+43 IF APCHSVST]""
WRITE APCHSVST,!
+44 ;IHS/CMI/LAB - patch 11 added Notice of Privacy act display
+45 SET APCHSNPP=$GET(^AUPNNPP(APCHSPAT,0))
+46 WRITE !,"NOTICE OF PRIVACY PRACTICES REC'D BY PATIENT? ",$$VAL^XBDIQ1(9000038,APCHSPAT,.02)
+47 WRITE !," DATE RECEIVED BY PATIENT: ",$$FMTE^XLFDT($PIECE(APCHSNPP,U,3))
+48 WRITE !," WAS ACKNOWLEDGEMENT SIGNED? ",$$VAL^XBDIQ1(9000038,APCHSPAT,.04)
+49 IF $PIECE(APCHSNPP,U,5)]""
Begin DoDot:1
+50 WRITE !," REASON: ",$PIECE(APCHSNPP,U,5)
End DoDot:1
+51 WRITE !
+52 KILL APCHSNPP
+53 WRITE !
+54 IF $DATA(^AUPNPAT(APCHSPAT,41))
WRITE "HEALTH RECORD NUMBERS:"
FOR APCHSFP=0:0
SET APCHSFP=$ORDER(^AUPNPAT(APCHSPAT,41,APCHSFP))
IF 'APCHSFP
QUIT
SET APCHSHRN=$PIECE(^(APCHSFP,0),U,2)
SET APCHSFAC=$PIECE(^DIC(4,APCHSFP,0),U,1)
WRITE ?24,$EXTRACT(1000000+APCHSHRN,2,7)," ",APCHSFAC,!
+55 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+56 IF $ORDER(^BDPRECN("C",APCHSPAT,0))
DO BDPDISP
GOTO REM
+57 WRITE "DESIGNATED PRIMARY CARE PROVIDER: ",APCHSPP,!
REM ;
+1 ;IHS/ANMC/LAB - added next 3 lines per Mosley 2/12/01
+2 IF $PIECE($GET(^BWP(APCHSPAT,0)),U,25)
SET A="WOMEN'S HEALTH DESIGNATED PROVIDER"
WRITE ?(38-$LENGTH(A)),A,": "_$$VAL^XBDIQ1(9002086,APCHSPAT,.25),!
+3 IF $PIECE($GET(^AUPNPAT(APCHSPAT,17)),U,1)
SET A="PRIMARY MENTAL HEALTH PROVIDER"
WRITE ?(38-$LENGTH(A)),A,": ",$EXTRACT($$VAL^XBDIQ1(9000001,APCHSPAT,1701),1,22),!
+4 IF $PIECE($GET(^AUPNPAT(APCHSPAT,17)),U,4)
SET A="SECONDARY MENTAL HEALTH PROVIDER"
WRITE ?(38-$LENGTH(A)),A,": ",$$VAL^XBDIQ1(9000001,APCHSPAT,1704),!
+5 ;I APCHSRE1]"" W "REMARKS:",?9,APCHSRE1,! W:APCHSRE2]"" ?9,APCHSRE2,!
+6 IF $DATA(APCHSRE1)
WRITE "REMARKS:",!
Begin DoDot:1
+7 SET APCHSX=0
FOR
SET APCHSX=$ORDER(APCHSRE1(APCHSX))
IF APCHSX=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+9 WRITE ?1,APCHSRE1(APCHSX),!
End DoDot:2
End DoDot:1
+10 IF APCHSNL<APCHTCNT
WRITE ?1,"[more]",!
+11 ;IHS/ANMC/LAB
IF $DATA(^BCPP(APCHSPAT))
Begin DoDot:1
+12 SET X="BCPAPI"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+13 ;IHS/ANMC/LAB - added for chronic pain registry
WRITE !,"CHRONIC PAIN REGISTRY STATUS: ",$$VAL^XBDIQ1(90246,APCHSPAT,.02)
+14 ;IHS/ANMC/LAB
DO ACTAGR^BCPAPI(.APCHAG,APCHSPAT,1)
WRITE ?45,$SELECT(APCHAG:"Opioid Agreement",1:"No Opioid Agreement"),!
End DoDot:1
+15 IF $PIECE($GET(^AUPNPAT(APCHSPAT,40)),U,2)]""
WRITE !,"Preferred Method of Receiving Reminders: ",$$VAL^XBDIQ1(9000001,APCHSPAT,4002),!
+16 DO DSPCMSRG
+17 ; CIA/PLS - 11/24/04 - WiseWoman Modification per Mike Mosley
+18 ;D WWDSPL(APCHSPAT) ; WW modification per Mike Mosley
+19 ; <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 KILL APCHSX,APCHSRE1,APCHSNL,APCHSFLD
+2 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 ;
BDPDISP ;EP - display providers from desg prov package
+1 WRITE ?30,"DESIGNATED PROVIDERS",!
+2 SET APCHSX=0
FOR
SET APCHSX=$ORDER(^BDPRECN("C",APCHSPAT,APCHSX))
IF APCHSX'=+APCHSX
QUIT
Begin DoDot:1
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+4 ;get category and check health summary status
+5 SET A=$PIECE($GET(^BDPRECN(APCHSX,0)),U)
+6 IF A=""
QUIT
+7 IF '$DATA(^BDPTCAT(A,0))
QUIT
+8 IF $PIECE(^BDPTCAT(A,0),U,8)="N"
QUIT
+9 SET A=$$VAL^XBDIQ1(90360.1,APCHSX,.01)
IF A="DESIGNATED PRIMARY PROVIDER"
SET A="DESIGNATED PRIMARY CARE PROVIDER"
WRITE ?(38-$LENGTH(A)),A,": "_$$VAL^XBDIQ1(90360.1,APCHSX,.03),!
+10 QUIT
End DoDot:1
+11 QUIT
WWDSPL(DFN) ;
+1 NEW AGE,STAT,SDATE,WW
+2 ; Must be a female patient
IF $EXTRACT(APCHSEX,1)'="F"
QUIT ""
+3 SET STAT=""
SET SDATE=0
+4 SET WW=$$WWENPROC(DFN)
+5 IF WW
Begin DoDot:1
+6 SET STAT="ENROLLED"
SET SDATE=WW
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET STAT=$$GET1^DIQ(9000001,DFN,1709)
+9 IF $LENGTH(STAT)
Begin DoDot:2
+10 SET SDATE=$$GET1^DIQ(9000001,DFN,1710,"I")
End DoDot:2
+11 IF '$TEST
Begin DoDot:2
+12 SET AGE=$$AGE^AUPNPAT(DFN)
+13 IF AGE>29&(AGE<65)
SET STAT="UNKNOWN"
End DoDot:2
End DoDot:1
+14 IF $LENGTH(STAT)
Begin DoDot:1
+15 WRITE !,"WW Status: ",STAT
IF SDATE
WRITE ?30,"WW Update Date: ",$$FMTE^XLFDT(SDATE)
+16 WRITE !!
End DoDot:1
+17 QUIT
+18 ; Return date of WW Enrollment Procedure or Zero
WWENPROC(DFN) ;
+1 NEW IEN,PDT
+2 SET PDT=0
+3 IF '$GET(DFN)
QUIT PDT
+4 SET (IEN,PDT)=0
FOR
SET IEN=$ORDER(^BWPCD("C",DFN,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+5 IF $$GET1^DIQ(9002086.1,IEN,4.01,"I")=1
Begin DoDot:2
+6 SET PDT=+$$GET1^DIQ(9002086.1,IEN,4.02,"I")
End DoDot:2
End DoDot:1
+7 QUIT PDT
SSN(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^DPT(P,0))
QUIT ""
+3 QUIT $SELECT($LENGTH($PIECE(^DPT(P,0),U,9))=9:$JUSTIFY("XXX-XX-"_$EXTRACT($PIECE(^DPT(P,0),U,9),6,9),11),1:$JUSTIFY($PIECE(^DPT(P,0),U,9),11))
