BSDX41A ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
;
; Support routines for BSDX HEALTH SUMMARY remote procedure
;
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",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)
;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(^DPT(APCHSPAT,"VET"),U)="Y" D VSTAT^APCHS1
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=^DPT(APCHSPAT,.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
S APCHOTPH=$P($G(^AUPNPAT(APCHSPAT,18)),U,1)
;demographics output
DEMDSP ; output for demographics taken from APCHS1
I $G(APCHSBRK)]"" X APCHSBRK
I $$DOD^AUPNPAT(APCHSPAT)]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="*** DOD: "_$$FMTE^XLFDT($$DOD^AUPNPAT(APCHSPAT),"2D")_" ***"_$C(30)
S BSDXTMP=APCHSNAM_$$FILL^BSDX41(34-$L(APCHSNAM)," ")
I APCHSDOB]"" S BSDXTMP=BSDXTMP_"DOB: "_APCHSDOB_" "_$$AGE(APCHSPAT,DT,"R")_" "
I APCHSEX]"" S BSDXTMP=BSDXTMP_APCHSEX_" "
D
. I APCHSBT["/" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(33)_APCHSBT_$C(30) Q
. I APCHSBT]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_APCHSBT_$C(30)
. Q
I APCHSTR]""!(APCHSMNM]"") S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$S(APCHSTR]"":$E(APCHSTR,1,33),1:"")_$S(APCHSSN]"":$$FILL^BSDX41($S((APCHSTR]"")&(APCHSSN]""):34-$L(APCHSTR),1:34))_"SSN: "_APCHSSN,1:"")_$C(30)
I APCHSMNM]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(33)_"MOTHER'S MAIDEN NAME: "_APCHSMNM_$C(30)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=APCHSHPH_APCHSOPH_$S(APCHSFNM]"":$$FILL^BSDX41(33-($L(APCHSHPH)+$L(APCHSOPH)))_"FATHER'S NAME: "_APCHSFNM,1:"")_$C(30)
I APCHOTPH]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="OTHER PHONE: "_APCHOTPH_$C(30)
I APCHSCMR]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=APCHSCMR_$C(30) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
I APCHSLUD]""!(APCHSEL]"") D
. I APCHSLUD]"" S BSDXTMP="LAST UPDATED: "_APCHSLUD_" "
. I APCHSEL]"" D
. . S BSDXTMP=BSDXTMP_$$FILL^BSDX41(33-$L("LAST UPDATED: "_APCHSLUD_" "))_"ELIGIBILITY: "_APCHSEL
. S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
I APCHSVST]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=APCHSVST_$C(30)
;IHS/CMI/LAB - patch 11 added Notice of Privacy act display
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
S APCHSNPP=$G(^AUPNNPP(APCHSPAT,0))
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="NOTICE OF PRIVACY PRACTICES REC'D BY PATIENT? "_$$VAL^XBDIQ1(9000038,APCHSPAT,.02)_$C(30)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=" DATE RECEIVED BY PATIENT: "_$$FMTE^XLFDT($P(APCHSNPP,U,3))_$C(30)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=" WAS ACKNOWLEDGEMENT SIGNED? "_$$VAL^XBDIQ1(9000038,APCHSPAT,.04)_$C(30)
I $P(APCHSNPP,U,5)]"" D
.S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=" REASON: "_$P(APCHSNPP,U,5)_$C(30)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
K APCHSNPP
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
I $D(^AUPNPAT(APCHSPAT,41)) S LCNT=0 S BSDXTMP="HEALTH RECORD NUMBERS:" F APCHSFP=0:0 S LCNT=LCNT+1 S APCHSFP=$O(^AUPNPAT(APCHSPAT,41,APCHSFP)) Q:'APCHSFP D
. S APCHSHRN=$P(^AUPNPAT(APCHSPAT,41,APCHSFP,0),U,2),APCHSFAC=$P(^DIC(4,APCHSFP,0),U,1)
. S BSDXTMP=BSDXTMP_$S(LCNT=1:" ",1:" ")_$E(1000000+APCHSHRN,2,7)_" "_APCHSFAC
I $G(APCHSKP)]"" X APCHSCKP Q:$D(APCHSQIT) ;SAT What is this.
I $O(^BDPRECN("C",APCHSPAT,0)) D BDPDISP G REM
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_"DESIGNATED PROVIDER: "_APCHSPP_$C(30)
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" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(38-$L(A))_A_": "_$$VAL^XBDIQ1(9002086,APCHSPAT,.25)_$C(30)
I $P($G(^AUPNPAT(APCHSPAT,17)),U,1) S A="PRIMARY MENTAL HEALTH PROVIDER" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(38-$L(A))_A_": "_$E($$VAL^XBDIQ1(9000001,APCHSPAT,1701),1,22)_$C(30)
I $P($G(^AUPNPAT(APCHSPAT,17)),U,4) S A="SECONDARY MENTAL HEALTH PROVIDER" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(38-$L(A))_A_": "_$$VAL^XBDIQ1(9000001,APCHSPAT,1704)_$C(30)
I APCHSRE1]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="REMARKS: "_APCHSRE1_$C(30) I APCHSRE2]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=" "_APCHSRE2_$C(30)
I $D(^BCPP(APCHSPAT)) D ;IHS/ANMC/LAB
.S X="BCPAPI" X ^%ZOSF("TEST") I '$T Q
.S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
.S BSDXTMP="CHRONIC PAIN REGISTRY STATUS: "_$$VAL^XBDIQ1(90246,APCHSPAT,.02) ;IHS/ANMC/LAB - added for chronic pain registry
.D ACTAGR^BCPAPI(.APCHAG,APCHSPAT,1) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_" "_$S(APCHAG:"Opioid Agreement",1:"No Opioid Agreement")_$C(30)
D DSPCMSRG
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
Q:'$D(^ACM(41,"D",APCHSPAT))
S APCHSJ=1
F APCHSI=0:0 S APCHSI=$O(^ACM(41,"AC",APCHSPAT,APCHSI)) Q:'APCHSI I $P(^ACM(41.1,APCHSI,0),U,7) S BSDXTMP=APCHSJ_" ON CMS REGISTER(S): " D
.S APCHSJ=0 S BSDXTMP=BSDXTMP_$P(^ACM(41.1,APCHSI,0),U)
.S APCHSK=^ACM(41,"AC",APCHSPAT,APCHSI) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_" Status: "_$$VAL^XBDIQ1(9002241,APCHSK,1)_$C(30)
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
;
BDPDISP ;EP - display providers from desg prov package
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="DESIGNATED PROVIDERS"_$C(30)
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 BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=A_": "_$$VAL^XBDIQ1(90360.1,APCHSX,.03)_$C(30)
.Q
Q
;
BSDX41A ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
+1 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
+2 ;
+3 ; Support routines for BSDX HEALTH SUMMARY remote procedure
+4 ;
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",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^APCHS1(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(^DPT(APCHSPAT,"VET"),U)="Y"
DO VSTAT^APCHS1
+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=^DPT(APCHSPAT,.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 SET APCHOTPH=$PIECE($GET(^AUPNPAT(APCHSPAT,18)),U,1)
+20 ;demographics output
DEMDSP ; output for demographics taken from APCHS1
+1 IF $GET(APCHSBRK)]""
XECUTE APCHSBRK
+2 IF $$DOD^AUPNPAT(APCHSPAT)]""
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="*** DOD: "_$$FMTE^XLFDT($$DOD^AUPNPAT(APCHSPAT),"2D")_" ***"_$CHAR(30)
+3 SET BSDXTMP=APCHSNAM_$$FILL^BSDX41(34-$LENGTH(APCHSNAM)," ")
+4 IF APCHSDOB]""
SET BSDXTMP=BSDXTMP_"DOB: "_APCHSDOB_" "_$$AGE(APCHSPAT,DT,"R")_" "
+5 IF APCHSEX]""
SET BSDXTMP=BSDXTMP_APCHSEX_" "
+6 Begin DoDot:1
+7 IF APCHSBT["/"
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(33)_APCHSBT_$CHAR(30)
QUIT
+8 IF APCHSBT]""
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_APCHSBT_$CHAR(30)
+9 QUIT
End DoDot:1
+10 IF APCHSTR]""!(APCHSMNM]"")
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$SELECT(APCHSTR]"":$EXTRACT(APCHSTR,1,33),1:"")_$SELECT(APCHSSN]"":$$FILL^BSDX41($SELECT((APCHSTR]"")&(APCHSSN]""):34-$LENGTH(APCHSTR),1:34))_"SSN: "_APCHSSN,1:"")_$CHAR(30)
+11 IF APCHSMNM]""
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(33)_"MOTHER'S MAIDEN NAME: "_APCHSMNM_$CHAR(30)
+12 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=APCHSHPH_APCHSOPH_$SELECT(APCHSFNM]"":$$FILL^BSDX41(33-($LENGTH(APCHSHPH)+$LENGTH(APCHSOPH)))_"FATHER'S NAME: "_APCHSFNM,1:"")_$CHAR(30)
+13 IF APCHOTPH]""
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="OTHER PHONE: "_APCHOTPH_$CHAR(30)
+14 IF APCHSCMR]""
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=APCHSCMR_$CHAR(30)
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+15 IF APCHSLUD]""!(APCHSEL]"")
Begin DoDot:1
+16 IF APCHSLUD]""
SET BSDXTMP="LAST UPDATED: "_APCHSLUD_" "
+17 IF APCHSEL]""
Begin DoDot:2
+18 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(33-$LENGTH("LAST UPDATED: "_APCHSLUD_" "))_"ELIGIBILITY: "_APCHSEL
End DoDot:2
+19 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
End DoDot:1
+20 IF APCHSVST]""
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=APCHSVST_$CHAR(30)
+21 ;IHS/CMI/LAB - patch 11 added Notice of Privacy act display
+22 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+23 SET APCHSNPP=$GET(^AUPNNPP(APCHSPAT,0))
+24 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="NOTICE OF PRIVACY PRACTICES REC'D BY PATIENT? "_$$VAL^XBDIQ1(9000038,APCHSPAT,.02)_$CHAR(30)
+25 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=" DATE RECEIVED BY PATIENT: "_$$FMTE^XLFDT($PIECE(APCHSNPP,U,3))_$CHAR(30)
+26 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=" WAS ACKNOWLEDGEMENT SIGNED? "_$$VAL^XBDIQ1(9000038,APCHSPAT,.04)_$CHAR(30)
+27 IF $PIECE(APCHSNPP,U,5)]""
Begin DoDot:1
+28 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=" REASON: "_$PIECE(APCHSNPP,U,5)_$CHAR(30)
End DoDot:1
+29 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+30 KILL APCHSNPP
+31 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+32 IF $DATA(^AUPNPAT(APCHSPAT,41))
SET LCNT=0
SET BSDXTMP="HEALTH RECORD NUMBERS:"
FOR APCHSFP=0:0
SET LCNT=LCNT+1
SET APCHSFP=$ORDER(^AUPNPAT(APCHSPAT,41,APCHSFP))
IF 'APCHSFP
QUIT
Begin DoDot:1
+33 SET APCHSHRN=$PIECE(^AUPNPAT(APCHSPAT,41,APCHSFP,0),U,2)
SET APCHSFAC=$PIECE(^DIC(4,APCHSFP,0),U,1)
+34 SET BSDXTMP=BSDXTMP_$SELECT(LCNT=1:" ",1:" ")_$EXTRACT(1000000+APCHSHRN,2,7)_" "_APCHSFAC
End DoDot:1
+35 ;SAT What is this.
IF $GET(APCHSKP)]""
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+36 IF $ORDER(^BDPRECN("C",APCHSPAT,0))
DO BDPDISP
GOTO REM
+37 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_"DESIGNATED PROVIDER: "_APCHSPP_$CHAR(30)
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"
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(38-$LENGTH(A))_A_": "_$$VAL^XBDIQ1(9002086,APCHSPAT,.25)_$CHAR(30)
+3 IF $PIECE($GET(^AUPNPAT(APCHSPAT,17)),U,1)
SET A="PRIMARY MENTAL HEALTH PROVIDER"
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(38-$LENGTH(A))_A_": "_$EXTRACT($$VAL^XBDIQ1(9000001,APCHSPAT,1701),1,22)_$CHAR(30)
+4 IF $PIECE($GET(^AUPNPAT(APCHSPAT,17)),U,4)
SET A="SECONDARY MENTAL HEALTH PROVIDER"
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(38-$LENGTH(A))_A_": "_$$VAL^XBDIQ1(9000001,APCHSPAT,1704)_$CHAR(30)
+5 IF APCHSRE1]""
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="REMARKS: "_APCHSRE1_$CHAR(30)
IF APCHSRE2]""
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=" "_APCHSRE2_$CHAR(30)
+6 ;IHS/ANMC/LAB
IF $DATA(^BCPP(APCHSPAT))
Begin DoDot:1
+7 SET X="BCPAPI"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+8 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+9 ;IHS/ANMC/LAB - added for chronic pain registry
SET BSDXTMP="CHRONIC PAIN REGISTRY STATUS: "_$$VAL^XBDIQ1(90246,APCHSPAT,.02)
+10 DO ACTAGR^BCPAPI(.APCHAG,APCHSPAT,1)
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_" "_$SELECT(APCHAG:"Opioid Agreement",1:"No Opioid Agreement")_$CHAR(30)
End DoDot:1
+11 DO DSPCMSRG
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
+2 ;
DSPCMSRG ; DISPLAY MEMBERSHIP IN CMS REGISTER
+1 IF '$DATA(^ACM(41,"D",APCHSPAT))
QUIT
+2 SET APCHSJ=1
+3 FOR APCHSI=0:0
SET APCHSI=$ORDER(^ACM(41,"AC",APCHSPAT,APCHSI))
IF 'APCHSI
QUIT
IF $PIECE(^ACM(41.1,APCHSI,0),U,7)
SET BSDXTMP=APCHSJ_" ON CMS REGISTER(S): "
Begin DoDot:1
+4 SET APCHSJ=0
SET BSDXTMP=BSDXTMP_$PIECE(^ACM(41.1,APCHSI,0),U)
+5 SET APCHSK=^ACM(41,"AC",APCHSPAT,APCHSI)
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_" Status: "_$$VAL^XBDIQ1(9002241,APCHSK,1)_$CHAR(30)
End DoDot:1
+6 QUIT
+7 ;
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 ;
BDPDISP ;EP - display providers from desg prov package
+1 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="DESIGNATED PROVIDERS"_$CHAR(30)
+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)
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=A_": "_$$VAL^XBDIQ1(90360.1,APCHSX,.03)_$CHAR(30)
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
