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