Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BSDX41B

BSDX41B.m

Go to the documentation of this file.
BSDX41B ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
 ;
 ; Support routines for BSDX HEALTH SUMMARY remote procedure
 ;
INS ; ******************* INSURANCE * 9000003, 9000004, 9000006 *********
 I $O(^AUPNMCD("B",APCHSPAT,0))="",'$D(^AUPNMCR(APCHSPAT)),'$D(^AUPNPRVT(APCHSPAT)),'$D(^AUPNRRE(APCHSPAT)) Q
 I $G(APCHSCKP)'="" X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK
 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="INSURANCE                      NUMBER      SUFF COV  EL DATE  SIG DATE END DATE"_$C(30)
 D MAID,MCARE,THIRD,RR
INSX K APCHSPDN,APCHSINS,APCHSEDN,APCHSN,APCHSIDN,APCHSDTL,APCHSDTN,APCHSUFF,APCHSCOV,APCHSDTS,APCHSI,APCHSJ,APCHSITB
 Q
 ;
MAID ;ENTRY POINT
 ; MEDICAID
 K APCHSITB
 ;<SETUP>
 S APCHSPDN=0 F APCHSQ=0:0 S APCHSPDN=$O(^AUPNMCD("B",APCHSPAT,APCHSPDN)) Q:APCHSPDN=""  D BMAID
 ;<DISPLAY>
 S APCHSI=0 F APCHSQ=0:0 S APCHSI=$O(APCHSITB(APCHSI)) Q:APCHSI=""  S APCHSJ=$O(APCHSITB(APCHSI,0)) S APCHSP=APCHSITB(APCHSI,APCHSJ) S APCHSPDN=$P(APCHSP,";",1),APCHSEDN=$P(APCHSP,";",2) D DMAID
 ;<CLEANUP>
MAIDX K APCHSCOV,APCHSDTL,APCHSDTN,APCHSDTS,APCHSEDN,APCHSI,APCHSIDN,APCHSINS,APCHSJ,APCHSN,APCHSPDN,APCHSUFF,Y,APCHSXDT,APCHSNM
 Q
BMAID Q:'$D(^AUPNMCD(APCHSPDN))
 S APCHSEDN=0 F APCHSQ=0:0 S APCHSEDN=$O(^AUPNMCD(APCHSPDN,11,APCHSEDN)) Q:'APCHSEDN  S APCHSP=^(APCHSEDN,0) S APCHSI=$P(^AUPNMCD(APCHSPDN,0),U,4)_"-"_$P(APCHSP,U,3),APCHSJ=9999999-$P(APCHSP,U,1) S APCHSITB(APCHSI,APCHSJ)=APCHSPDN_";"_APCHSEDN
 Q
DMAID ;
 S APCHSN=^AUPNMCD(APCHSPDN,0)
 S APCHSINS=$S($P(APCHSN,U,2):$P(^AUTNINS($P(APCHSN,U,2),0),U,1),1:"???") ;IHS/CMI/LAB - patch 6 prevent sbscr
 S APCHSNM=^AUPNMCD(APCHSPDN,11,APCHSEDN,0)
 S Y=$P(APCHSNM,U,1) X:$G(APCHSCVD)'="" APCHSCVD S APCHSDTL=Y
 ;-- IHS/CMI/MAW add set of exp date variable, quit if not current
 S (APCHSXDT,Y)=$P(APCHSNM,U,2) X:$G(APCHSCVD)'="" APCHSCVD S APCHSDTN=Y
 I APCHSXDT="" S APCHSXDT=9999999
 Q:APCHSXDT<DT
 ;-- IHS/CMI/MAW end of mods
 X:$G(APCHSCKP)'="" APCHSCKP Q:$D(APCHSQIT)  W:APCHSNPG "(Medicaid cont.)",!
 S X=$P($G(^DIC(5,+$P(APCHSN,U,4),0)),U,2)
 S BSDXDL=$S(X="":"??",1:X)_" "_APCHSINS_$$FILL^BSDX41(32-$L($S(X="":"??",1:X)_" "_APCHSINS))_$P(APCHSN,U,3)
 S BSDXDL=BSDXDL_$$FILL^BSDX41(49-$L(BSDXDL))_$P(APCHSNM,U,3)
 S BSDXDL=BSDXDL_$$FILL^BSDX41(54-$L(BSDXDL))_APCHSDTL
 S BSDXDL=BSDXDL_$$FILL^BSDX41(72-$L(BSDXDL))_APCHSDTN
 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDL_$C(30)
 I $P(APCHSN,U,10)]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="  "_"Plan Name: "_$$VAL^XBDIQ1(9000004,APCHSPDN,.11)_$C(30)
 Q
MCARE ;ENTRY POINT
 ; MEDICARE
 Q:'$D(^AUPNMCR(APCHSPAT))
 S APCHSN=^AUPNMCR(APCHSPAT,0)
 Q:'$D(^AUPNMCR(APCHSPAT,0))  ;CMI/LAB
 S APCHSINS=$S($P(APCHSN,U,2):$P(^AUTNINS($P(APCHSN,U,2),0),U,1),1:"???") ;IHS/CMI/LAB - prevent sbscr
 S APCHSUFF=$P(APCHSN,U,4) S:APCHSUFF]"" APCHSUFF=$P(^AUTTMCS(APCHSUFF,0),U,1)
 K APCHSITB
 S APCHSEDN=0 F APCHSQ=0:0 S APCHSEDN=$O(^AUPNMCR(APCHSPAT,11,APCHSEDN)) Q:APCHSEDN'=+APCHSEDN  S APCHSP=^(APCHSEDN,0) S APCHSI=$P(APCHSN,U,2)_"-"_$P(APCHSP,U,3),APCHSJ=9999999-$P(APCHSP,U,1) S APCHSITB(APCHSI,APCHSJ)=APCHSPAT_";"_APCHSEDN
 S APCHSI=0 F APCHSQ=0:0 S APCHSI=$O(APCHSITB(APCHSI)) Q:APCHSI=""  S APCHSJ=$O(APCHSITB(APCHSI,0)) S APCHSP=APCHSITB(APCHSI,APCHSJ) S APCHSPDN=$P(APCHSP,";",1),APCHSEDN=$P(APCHSP,";",2) D DMCARE
 I $X'=0 D
 . S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
 Q
DMCARE ;
 S APCHSNM=^AUPNMCR(APCHSPDN,11,APCHSEDN,0)
 S Y=$P(APCHSNM,U,1) X:$G(APCHSCVD)'="" APCHSCVD S APCHSDTL=Y
 ;-- IHS/CMI/MAW add set of exp date variable, quit if not current
 S (APCHSXDT,Y)=$P(APCHSNM,U,2) X:$G(APCHSCVD)'="" APCHSCVD S APCHSDTN=Y
 I APCHSXDT="" S APCHSXDT=9999999
 Q:APCHSXDT<DT
 ;-- IHS/CMI/MAW end of mods
 X:$G(APCHSCKP)'="" APCHSCKP Q:$D(APCHSQIT)
 S APCHSCOV=$P(APCHSNM,U,3)
 S APCHSDTS="" I APCHSCOV="B" S Y=$P(^AUPNPAT(APCHSPAT,0),U,4) X:$G(APCHSCVD)'="" APCHSCVD S APCHSDTS=Y
 X:$G(APCHSCKP)'="" APCHSCKP Q:$D(APCHSQIT)
 I $G(APCHSNPG) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="(Medicare cont.)"_$C(30)
 S BSDXDSP=APCHSINS
 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(32-$L(BSDXDSP))_$P(APCHSN,U,3)
 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(44-$L(BSDXDSP))_APCHSUFF
 I $G(APCHSNPG) S BSDXDSP=BSDXDSP_"(Medicare cont.)"
 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$C(30)
 S BSDXDSP=$$FILL^BSDX41(48)_APCHSCOV
 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(54-$L(BSDXDSP))_APCHSDTL
 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(63-$L(BSDXDSP))_APCHSDTS
 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(72-$L(BSDXDSP))_APCHSDTN
 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$C(30)
 K APCHSXDT,APCHSNM
 Q
THIRD ;ENTRY POINT
 ; OTHER THIRD PARTY
 Q:$O(^AUPNPRVT(APCHSPAT,11,0))=""
 K APCHSITB
 S APCHSIDN=0 F APCHSQ=0:0 S APCHSIDN=$O(^AUPNPRVT(APCHSPAT,11,APCHSIDN)) Q:APCHSIDN'=+APCHSIDN  S APCHSP=^(APCHSIDN,0) S APCHSITB($P(APCHSP,U,1)_"-"_$P(APCHSP,U,3),9999999-$P(APCHSP,U,6))=APCHSIDN
 ;S APCHSI="" F APCHSQ=0:0 S APCHSI=$O(APCHSITB(APCHSI)) Q:APCHSI=""  S APCHSJ=$O(APCHSITB(APCHSI,0)) S APCHSIDN=APCHSITB(APCHSI,APCHSJ) D DTHIRD
 S APCHSI="" F APCHSQ=0:0 S APCHSI=$O(APCHSITB(APCHSI)) Q:APCHSI=""  S APCHSJ="" F  S APCHSJ=$O(APCHSITB(APCHSI,APCHSJ)) Q:APCHSJ=""  S APCHSIDN=APCHSITB(APCHSI,APCHSJ) D DTHIRD
 Q
DTHIRD S APCHSN=^AUPNPRVT(APCHSPAT,11,APCHSIDN,0)
 Q:$P(APCHSN,U,1)=""
 S APCHSINS=$P(^AUTNINS($P(APCHSN,U,1),0),U,1)
 S Y=$P(APCHSN,U,6) X:$G(APCHSCVD)'="" APCHSCVD S APCHSDTL=Y
 ;-- IHS/CMI/MAW add set of exp date variable, quit if not current
 S (APCHSXDT,Y)=$P(APCHSN,U,7) X:$G(APCHSCVD)'="" APCHSCVD S APCHSDTN=Y
 I APCHSXDT="" S APCHSXDT=9999999
 Q:APCHSXDT<DT
 ;-- IHS/CMI/MAW end of mods
 X:$G(APCHSCKP)'="" APCHSCKP Q:$D(APCHSQIT)  W:APCHSNPG "(3rd party cont.)",!
 ;IHS/CMI/GRL policy number field of Private Insurance Eligible is obsolete.  Per Adrian Lujan,
 ;following code looks at the Member Number field of Insurer multiple.  If null, then get policy number
 ;from Policy Holder File
 S $P(APCHSN,U,2)=$P($G(^AUPNPRVT(APCHSPAT,11,APCHSIDN,2)),U)  ;member number
 I $P($G(APCHSN),U,2)']"",$P(APCHSN,U,8) S $P(APCHSN,U,2)=$P($G(^AUPN3PPH($P(APCHSN,U,8),0)),U,4)  ;policy number 
 ;IHS/CMI/GRL  end of patch
 S BSDXDSP=APCHSINS
 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(32-$L(BSDXDSP))_$P(APCHSN,U,2)
 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(49-$L(BSDXDSP))_$P(APCHSN,U,3)
 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(54-$L(BSDXDSP))_APCHSDTL
 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(72-$L(BSDXDSP))_APCHSDTN
 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
 K APCHSXDT
 Q
RR ;EP
 ; RAILROAD RETIREMENT
 Q:'$D(^AUPNRRE(APCHSPAT))
 S APCHSN=^AUPNRRE(APCHSPAT,0)
 S APCHSINS=$P(^AUTNINS($P(APCHSN,U,2),0),U,1)
 S APCHSUFF=$P(APCHSN,U,3)
 K APCHSITB
 S APCHSEDN=0 F APCHSQ=0:0 S APCHSEDN=$O(^AUPNRRE(APCHSPAT,11,APCHSEDN)) Q:APCHSEDN'=+APCHSEDN  S APCHSP=^(APCHSEDN,0) S APCHSI=$P(APCHSN,U,2)_"-"_$P(APCHSP,U,3),APCHSJ=9999999-$P(APCHSP,U,1) S APCHSITB(APCHSI,APCHSJ)=APCHSPAT_";"_APCHSEDN
 S APCHSI=0 F APCHSQ=0:0 S APCHSI=$O(APCHSITB(APCHSI)) Q:APCHSI=""  S APCHSJ=$O(APCHSITB(APCHSI,0)) S APCHSP=APCHSITB(APCHSI,APCHSJ) S APCHSPDN=$P(APCHSP,";",1),APCHSEDN=$P(APCHSP,";",2) D DRR
 I $X'=0 D
 . S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
 Q
DRR ;
 S APCHSNM=^AUPNRRE(APCHSPDN,11,APCHSEDN,0)
 S Y=$P(APCHSNM,U,1) X:$G(APCHSCVD)'="" APCHSCVD S APCHSDTL=Y
 ;-- IHS/CMI/MAW add set of exp date variable, quit if not current
 S (APCHSXDT,Y)=$P(APCHSNM,U,2) X:$G(APCHSCVD)'="" APCHSCVD S APCHSDTN=Y
 I APCHSXDT="" S APCHSXDT=9999999
 Q:APCHSXDT<DT
 ;-- IHS/CMI/MAW end of mods
 S APCHSCOV=$P(APCHSNM,U,3)
 X:$G(APCHSCKP)'="" APCHSCKP Q:$D(APCHSQIT)  W:APCHSNPG "(Railroad Retirement cont.)",!
 S BSDXDSP=APCHSINS
 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(32-$L(BSDXDSP))_$P(APCHSN,U,4)
 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(44-$L(BSDXDSP))_APCHSUFF
 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(49-$L(BSDXDSP))_APCHSCOV
 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(54-$L(BSDXDSP))_APCHSDTL
 S BSDXDSP=BSDXDSP_$$FILL^BSDX41(72-$L(BSDXDSP))_APCHSDTN
 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
 K APCHSNM,APCHSXDT
 Q
 ;
 ;
HFACT ; ******************** HEALTH FACTORS * 9000019 *********  (APCHS4A)
 ; <SETUP>
 Q:'$D(^AUPNVHF("AC",APCHSPAT))
 S APCHSSNM=APCHSNDM,APCHSSDM=APCHSDLM
 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK
 ; <DISPLAY>
 S APCHSHP=0
 I $O(^APCHSCTL(APCHSTYP,7,0)) D
 . S APCHSHFS="" F  S APCHSHFS=$O(^APCHSCTL(APCHSTYP,7,"B",APCHSHFS)) Q:'APCHSHFS  D
 .. S APCHSHFI="" F  S APCHSHFI=$O(^APCHSCTL(APCHSTYP,7,"B",APCHSHFS,APCHSHFI)) Q:'APCHSHFI  D
 ... S APCHSN=^APCHSCTL(APCHSTYP,7,APCHSHFI,0) S APCHSFC=$P(APCHSN,U,2),APCHSFT=$P(APCHSN,U,3),APCHSFD=$P(APCHSN,U,4) D ONECAT
 . Q
 E  D
 . S APCHSFC="" F  S APCHSFC=$O(^AUTTHF("AD","C",APCHSFC)) Q:'APCHSFC  S (APCHSFT,APCHSFD)="" D ONECAT
 . Q
 ; <CLEANUP>
HFACTX K APCHSCFI,APCHSDAT,APCHSDT2,APCHSFC,APCHSFD,APCHSFDP,APCHSFN,APCHSFSS,APCHSFT,APCHSFTB,APCHSHFI,APCHSHFS,APCHSHP,APCHSI,APCHSIVD,APCHSNDT,APCHSNI,APCHSPVD,APCHSSDM,APCHSSNM,APCHSTNP,Y,X
 Q
 ;
ONECAT ;
 Q:APCHSFC=""
 S:APCHSFD="" APCHSFD="Y"
 S:APCHSFT="" APCHSFT=$P(^AUTTHF(APCHSFC,0),U)
 ;W "Category=",APCHSFC," Name=",$P(^AUTTHF(APCHSFC,0),U)," Title=",APCHSFT," Display=",APCHSFD,!
 S APCHSTNP=1
 K APCHSFTB
 S APCHSCFI="" F  S APCHSCFI=$O(^AUTTHF("AC",APCHSFC,APCHSCFI)) Q:'APCHSCFI  D ONEFACT
 D DISPDATA
 Q
ONEFACT ;
 S APCHSN=^AUTTHF(APCHSCFI,0),APCHSFN=$P(APCHSN,U)
 ;W ?3,APCHSN,!
 S APCHSNDM=APCHSSNM,APCHSDLM=APCHSSDM
 S APCHSPVD=0
 F APCHSIVD=0:0 S APCHSIVD=$O(^AUPNVHF("AA",APCHSPAT,APCHSCFI,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  D ONEDATE Q:$D(APCHSQIT)  S:(APCHSDAT'=APCHSPVD) APCHSNDM=APCHSNDM-1,APCHSPVD=APCHSDAT Q:APCHSNDM=0  Q:APCHSFD="Y"
 Q
 ;
ONEDATE ;
 S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y S APCHSNDT=(APCHSDAT'=APCHSPVD)
 D:APCHSTNP TPRINT
 S APCHSNI="" F  S APCHSNI=$O(^AUPNVHF("AA",APCHSPAT,APCHSCFI,APCHSIVD,APCHSNI)) Q:'APCHSNI  D SETFACT
 Q
SETFACT S APCHSN=^AUPNVHF(APCHSNI,0)
 S APCHSFSS="" S X=$P(APCHSN,U,4) I X]"" S Y=$P(^DD(9000019,.04,0),U,3) F APCHSI=1:1:$L(Y,";") S APCHSFDP=$P(Y,";",APCHSI) I X=$P(APCHSFDP,":") S APCHSFSS=$P(APCHSFDP,":",2) Q
 S APCHSQTY=$P(APCHSN,U,6)
 S APCHSFTB(APCHSIVD,APCHSDAT_U_APCHSFN_U_APCHSFSS_U_APCHSQTY_U_$P(APCHSN,U))=""
 Q
DISPDATA ; DISPLAY TABLED DATA
 S APCHSDT2=""
 S APCHSIVD=0 F  S APCHSIVD=$O(APCHSFTB(APCHSIVD)) Q:'APCHSIVD  S APCHSN="" F  S APCHSN=$O(APCHSFTB(APCHSIVD,APCHSN)) Q:APCHSN=""  D DISP2
 Q
DISP2 ;
 S APCHSDAT=$P(APCHSN,U),APCHSFN=$P(APCHSN,U,2),APCHSFSS=$P(APCHSN,U,3)
 S BSDXTMP=""
 I APCHSDAT'=APCHSDT2 S BSDXTMP=APCHSDAT S BSDXTMP=BSDXTMP_$$FILL^BSDX41(10-$L(BSDXTMP))_APCHSFN_$S(APCHSFSS]"":" ("_APCHSFSS_")",1:"") D:$P(APCHSN,U,4)]"" WQTY S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
 S APCHSDT2=APCHSDAT
 Q
WQTY ;write out quantity and phrase
 NEW X S X=$P(APCHSN,U,5) Q:'X
 S X=$P(^AUTTHF(X,0),U,11)
 I X="" S X="QUANTITY"
 S X=X_": "
 S BSDXTMP=BSDXTMP_"  "_X_$P(APCHSN,U,4)
 Q
TPRINT ; PRINT TITLE
 S APCHSTNP=0
 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="~~ "_APCHSFT_" ~~"_$C(30) ;temporary
 Q
 ;
 ;not used YET
EDUCASSE ;EP - called from component educational assessment
 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK
 W !,"Most recent Health Factor recorded.",!
 W !,"   Learning Preference:  ",$$LASTHF^APCHSMU(APCHSPAT,"LEARNING PREFERENCE","B"),!
 ;X APCHSCKP Q:$D(APCHSQIT)
 ;W !,"    Readiness to Learn:  ",$$LASTHF^APCHSMU(APCHSPAT,"READINESS TO LEARN","B"),!
 X APCHSCKP Q:$D(APCHSQIT)
 W !,"  Barriers to Learning:  "
 S C=$O(^AUTTHF("B","BARRIERS TO LEARNING",0)) ;ien of category passed
 I '$G(C) Q
 S H=0 K APCHO
 F  S H=$O(^AUTTHF("AC",C,H))  Q:'+H  D
 .  Q:'$D(^AUPNVHF("AA",APCHSPAT,H))
 .  S D=$O(^AUPNVHF("AA",APCHSPAT,H,""))
 .  Q:'D
 .  S APCHO(H,D)=$O(^AUPNVHF("AA",APCHSPAT,H,D,""))
 .  Q
 S APCHX="" F  S APCHX=$O(APCHO(APCHX)) Q:APCHX=""!($D(APCHSQIT))  D
 .S D=$O(APCHO(APCHX,0))
 .X APCHSCKP Q:$D(APCHSQIT)
 .W ?25,$$VAL^XBDIQ1(9000010.23,APCHO(APCHX,D),.01)_"  "_$$FMTE^XLFDT((9999999-D)),!
 Q