- APCLAL1A ; IHS/CMI/LAB - list refusals ;
- ;;2.0;IHS PCC SUITE;**2,4,11**;MAY 14, 2009;Build 58
- ;
- PROC ;EP
- S APCLCNT=0
- S APCLH=$H,APCLJ=$J
- K ^XTMP("APCLAL1",APCLJ,APCLH)
- D XTMP^APCLOSUT("APCLAL1","ALCOHOL SCREENING REPORT")
- ;go through exam ALCOHOL, then through AUPNPREF for refusals
- S DFN=0 F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN D
- .I '$G(APCLRPT4) Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
- .I $G(APCLRPT4) Q:'$D(^DIBT(APCLSEAT,1,DFN))
- .I APCLCOMT="O",$$COMMRES^AUPNPAT(DFN,"I")'=APCLCOMT("ONE") Q ;not in community
- .I APCLCOMT="S" S X=$$COMMRES^AUPNPAT(DFN,"E") I '$D(APCLTAX(X)) Q ;not in comm taxonomy
- .D PROC1
- .Q
- Q
- PROC1 ;
- K APCLG S %=DFN_"^ALL VISITS;DURING "_APCLBD_"-"_APCLED,E=$$START1^APCLDF(%,"APCLG(")
- S APCLE=0 F S APCLE=$O(APCLG(APCLE)) Q:APCLE'=+APCLE D
- .S APCLVIEN=$P(APCLG(APCLE),U,5)
- .Q:'APCLVIEN
- .S APCLDATE=$P(APCLG(APCLE),U,1)
- .I 'APCLEXBH S C=$$CLINIC^APCLV(APCLVIEN,"C") I C=14!(C=45)!(C=48) Q
- .I APCLLOCT="O",$P(^AUPNVSIT(APCLVIEN,0),U,6)'=APCLLOCT("ONE") Q
- .I APCLLOCT="S",$$VALI^XBDIQ1(9999999.06,$P(^AUPNVSIT(APCLVIEN,0),U,6),.05)'=APCLLOCT("SU") Q
- PEXS .S APCLEIEN=0 F S APCLEIEN=$O(^AUPNVXAM("AD",APCLVIEN,APCLEIEN)) Q:APCLEIEN'=+APCLEIEN D
- ..Q:'$D(^AUPNVXAM(APCLEIEN,0))
- ..S R=$P(^AUPNVXAM(APCLEIEN,0),U,1)
- ..Q:$P($G(^AUTTEXAM(+R,0)),U,2)'=35
- ..S APCLRES=$$VAL^XBDIQ1(9000010.13,APCLEIEN,.04) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
- ..S ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$PPV(APCLVIEN)_U_APCLRES_U_$$VAL^XBDIQ1(9000010.13,APCLEIEN,81101)_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLVIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$SPRV(APCLEIEN)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="EXAM"
- PMSRS .;
- .S APCLEIEN=0 F S APCLEIEN=$O(^AUPNVMSR("AD",APCLVIEN,APCLEIEN)) Q:APCLEIEN'=+APCLEIEN D
- ..Q:'$D(^AUPNVMSR(APCLEIEN,0))
- ..Q:$P($G(^AUPNVMSR(APCLEIEN,2)),U,1) ;ENTERED IN ERROR
- ..S R=$P(^AUPNVMSR(APCLEIEN,0),U,1)
- ..S R=$P($G(^AUTTMSR(+R,0)),U,1)
- ..I R'="AUDC",R'="AUDT",R'="CRFT" Q
- ..S APCLRES=R_" "_$$VAL^XBDIQ1(9000010.01,APCLEIEN,.04)
- ..S ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$PPV(APCLVIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLVIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$MPRV(APCLEIEN)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="MSR"
- PHF .;
- .S APCLEIEN=0 F S APCLEIEN=$O(^AUPNVHF("AD",APCLVIEN,APCLEIEN)) Q:APCLEIEN'=+APCLEIEN D
- ..Q:'$D(^AUPNVHF(APCLEIEN,0))
- ..S R=$P(^AUPNVHF(APCLEIEN,0),U,1)
- ..S R=$$VAL^XBDIQ1(9999999.64,R,.01)
- ..I R'["CAGE " Q
- ..S APCLRES=R
- ..S ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$PPV(APCLVIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLVIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$HFPRV(APCLEIEN)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="HF"
- PPVS .;
- .S APCLEIEN=0 F S APCLEIEN=$O(^AUPNVPOV("AD",APCLVIEN,APCLEIEN)) Q:APCLEIEN'=+APCLEIEN D
- ..Q:'$D(^AUPNVPOV(APCLEIEN,0))
- ..S R=$$VAL^XBDIQ1(9000010.07,APCLEIEN,.01)
- ..I R'="V79.1" Q
- ..S APCLRES=""
- ..S ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$PPV(APCLVIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLVIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$PVPRV(APCLEIEN)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="DX"
- PPEDS .;
- .S APCLEIEN=0 F S APCLEIEN=$O(^AUPNVPED("AD",APCLVIEN,APCLEIEN)) Q:APCLEIEN'=+APCLEIEN D
- ..Q:'$D(^AUPNVPED(APCLEIEN,0))
- ..S R=$P(^AUPNVPED(APCLEIEN,0),U,1)
- ..S R=$P($G(^AUTTEDT(+R,0)),U,2)
- ..I R'="AOD-SCR",R'="CD-SCR" Q
- ..S APCLRES=""
- ..S ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$PPV(APCLVIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLVIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$PEDPRV(APCLEIEN)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="PED"
- PCPTS .;
- .S APCLEIEN=0 F S APCLEIEN=$O(^AUPNVCPT("AD",APCLVIEN,APCLEIEN)) Q:APCLEIEN'=+APCLEIEN D
- ..Q:'$D(^AUPNVCPT(APCLEIEN,0))
- ..S R=$P(^AUPNVCPT(APCLEIEN,0),U)
- ..Q:'$$ICD^ATXAPI(R,$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0)),1)
- ..S APCLRES=""
- ..S ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$PPV(APCLVIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLVIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$CPTPRV(APCLEIEN)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="CPT"
- PREF ;now go through refusals in pcc
- S APCLRIEN=0 F S APCLRIEN=$O(^AUPNPREF("AC",DFN,APCLRIEN)) Q:APCLRIEN'=+APCLRIEN D
- .Q:'$D(^AUPNPREF(APCLRIEN,0))
- .Q:$P(^AUPNPREF(APCLRIEN,0),U,5)'=9999999.15
- .Q:$P(^AUPNPREF(APCLRIEN,0),U,6)'=APCLEXC
- .S APCLDATE=$P(^AUPNPREF(APCLRIEN,0),U,3)
- .Q:APCLDATE=""
- .Q:APCLDATE>APCLED
- .Q:APCLDATE<APCLBD
- .Q:$D(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)) ;already got one from v exam on this date
- .;S X=$O(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,0))
- .;I X]"",X<APCLDATE K ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,X)
- .S APCLRES=$$VAL^XBDIQ1(9000022,APCLRIEN,.07) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
- .S ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="REF"_U_"UNKNOWN"_U_APCLRES_U_$$VAL^XBDIQ1(9000022,APCLRIEN,1101)_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLRIEN_U
- .S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$PRVREF(APCLRIEN)
- .S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- .S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="EXAM"
- BH ;now go through BH
- Q:'APCLEXBH ;not if user doesn't want to
- S APCLSD=$$FMADD^XLFDT(APCLBD,-1),APCLSD=APCLSD_".9999"
- F S APCLSD=$O(^AMHREC("AF",DFN,APCLSD)) Q:APCLSD'=+APCLSD!($P(APCLSD,".")>APCLED) D BH1
- Q
- BH1 ;
- S APCLBIEN=0 F S APCLBIEN=$O(^AMHREC("AF",DFN,APCLSD,APCLBIEN)) Q:APCLBIEN'=+APCLBIEN D
- .S APCLDATE=$P(APCLSD,".")
- .Q:'$D(^AMHREC(APCLBIEN,0))
- .I APCLLOCT="O",$P(^AMHREC(APCLBIEN,0),U,4)'=APCLLOCT("ONE") Q
- .I APCLLOCT="S",$$VALI^XBDIQ1(9999999.06,$P(^AMHREC(APCLBIEN,0),U,4),.05)'=APCLLOCT("SU") Q
- .Q:$D(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)) ;already got one from PCC on this date
- .;S X=$O(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,0))
- .;I X]"",X<APCLDATE K ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,X)
- .S APCLRES=$$VAL^XBDIQ1(9002011,APCLBIEN,1403)
- .I APCLRES="" G BMSR
- .S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
- .S ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="BH"_U_$$BHPPNAME(APCLBIEN)_U_APCLRES_U_$$VAL^XBDIQ1(9002011,APCLBIEN,1601)_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLBIEN
- .S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
- .S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLBIEN
- .S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$S($P($G(^AMHREC(APCLBIEN,14)),U,2):$$VAL^XBDIQ1(9002011,APCLBIEN,1404),1:"UNKNOWN")
- .S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- BMSR .;
- .S APCLEIEN=0 F S APCLEIEN=$O(^AMHRMSR("AD",APCLBIEN,APCLEIEN)) Q:APCLEIEN'=+APCLEIEN D
- ..Q:'$D(^AMHRMSR(APCLEIEN,0))
- ..S R=$P(^AMHRMSR(APCLEIEN,0),U,1)
- ..S R=$P($G(^AUTTMSR(+R,0)),U,1)
- ..I R'="AUDC",R'="AUDT",R'="CRFT" Q
- ..S APCLRES=R_" "_$$VAL^XBDIQ1(9002011.12,APCLEIEN,.04)
- ..S ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="BH"_U_$$BHPPNAME(APCLBIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLBIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$BHPPNAME(APCLBIEN)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="MSR"
- BHF .;
- .S APCLEIEN=0 F S APCLEIEN=$O(^AMHRHF("AD",APCLBIEN,APCLEIEN)) Q:APCLEIEN'=+APCLEIEN D
- ..Q:'$D(^AMHRHF(APCLEIEN,0))
- ..S R=$P(^AMHRHF(APCLEIEN,0),U,1)
- ..S R=$$VAL^XBDIQ1(9999999.64,R,.01)
- ..I R'["CAGE " Q
- ..S APCLRES=R
- ..S ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$BHPPNAME(APCLBIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLBIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$BHPPNAME(APCLBIEN)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="HF"
- BPVS .;
- .S APCLEIEN=0 F S APCLEIEN=$O(^AMHRPRO("AD",APCLBIEN,APCLEIEN)) Q:APCLEIEN'=+APCLEIEN D
- ..Q:'$D(^AMHRPRO(APCLEIEN,0))
- ..S R=$$VAL^XBDIQ1(9002011.01,APCLEIEN,.01)
- ..I R'="29.1" Q
- ..S APCLRES=""
- ..S ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$BHPPNAME(APCLBIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLBIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$BHPPNAME(APCLBIEN)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="DX"
- BPEDS .;
- .S APCLEIEN=0 F S APCLEIEN=$O(^AMHREDU("AD",APCLBIEN,APCLEIEN)) Q:APCLEIEN'=+APCLEIEN D
- ..Q:'$D(^AMHREDU(APCLEIEN,0))
- ..S R=$P(^AMHREDU(APCLEIEN,0),U,1)
- ..S R=$P($G(^AUTTEDT(+R,0)),U,2)
- ..I R'="AOD-SCR",R'="CD-SCR" Q
- ..S APCLRES=""
- ..S ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$BHPPNAME(APCLBIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLBIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$BHPPNAME(APCLBIEN)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="PED"
- BCPTS .;
- .S APCLEIEN=0 F S APCLEIEN=$O(^AMHRPROC("AD",APCLBIEN,APCLEIEN)) Q:APCLEIEN'=+APCLEIEN D
- ..Q:'$D(^AMHRPROC(APCLEIEN,0))
- ..S R=$P(^AMHRPROC(APCLEIEN,0),U)
- ..Q:'$$ICD^ATXAPI(R,$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0)),1)
- ..S APCLRES=""
- ..S ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$BHPPNAME(APCLBIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLBIEN
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$BHPPNAME(APCLBIEN)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- ..S $P(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="CPT"
- Q
- ;
- BHPPNAME(R) ;EP primary provider internal # from 200
- NEW %,%1
- S %=0,%1="" F S %=$O(^AMHRPROV("AD",R,%)) Q:%'=+% I $P(^AMHRPROV(%,0),U,4)="P" S %1=$P(^AMHRPROV(%,0),U),%1=$P($G(^VA(200,%1,0)),U)
- I %1]"" Q %1
- Q "UNKNOWN"
- SPRV(E) ;
- I $P($G(^AUPNVXAM(E,12)),U,4) Q $$VAL^XBDIQ1(9000010.13,E,1204)
- Q "UNKNOWN"
- PRVREF(R) ;
- I $P($G(^AUPNPREF(R,12)),U,4)]"" Q $$VAL^XBDIQ1(9000022,R,1204)
- Q "UNKNOWN"
- PPV(V) ;
- NEW %
- S %=$$PRIMPROV^APCLV(V)
- I %=-1 Q "UNKNOWN"
- I %]"" Q %
- Q "UNKNOWN"
- CTR(X,Y) ;EP - Center X in a field Y wide.
- Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
- ;----------
- EOP ;EP - End of page.
- Q:$E(IOST)'="C"
- Q:IO'=IO(0)
- Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
- NEW DIR
- K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
- W !
- S DIR("A")="End of Report. Press Enter",DIR(0)="E" D ^DIR
- Q
- ;----------
- USR() ;EP - Return name of current user from ^VA(200.
- Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
- ;----------
- LOC() ;EP - Return location name from file 4 based on DUZ(2).
- Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
- ;----------
- ;
- MPRV(E) ;
- I $P($G(^AUPNVMSR(E,12)),U,4) Q $$VAL^XBDIQ1(9000010.01,E,1204)
- Q "UNKNOWN"
- HFPRV(E) ;
- I $P($G(^AUPNVHF(E,12)),U,4) Q $$VAL^XBDIQ1(9000010.22,E,1204)
- Q "UNKNOWN"
- PVPRV(E) ;
- I $P($G(^AUPNVPOV(E,12)),U,4) Q $$VAL^XBDIQ1(9000010.07,E,1204)
- Q "UNKNOWN"
- PEDPRV(E) ;
- I $P($G(^AUPNVPED(E,12)),U,4) Q $$VAL^XBDIQ1(9000010.16,E,1204)
- Q "UNKNOWN"
- CPTPRV(E) ;
- I $P($G(^AUPNVCPT(E,12)),U,4) Q $$VAL^XBDIQ1(9000010.18,E,1204)
- Q "UNKNOWN"
- APCLAL1A ; IHS/CMI/LAB - list refusals ;
- +1 ;;2.0;IHS PCC SUITE;**2,4,11**;MAY 14, 2009;Build 58
- +2 ;
- PROC ;EP
- +1 SET APCLCNT=0
- +2 SET APCLH=$HOROLOG
- SET APCLJ=$JOB
- +3 KILL ^XTMP("APCLAL1",APCLJ,APCLH)
- +4 DO XTMP^APCLOSUT("APCLAL1","ALCOHOL SCREENING REPORT")
- +5 ;go through exam ALCOHOL, then through AUPNPREF for refusals
- +6 SET DFN=0
- FOR
- SET DFN=$ORDER(^AUPNPAT(DFN))
- IF DFN'=+DFN
- QUIT
- Begin DoDot:1
- +7 IF '$GET(APCLRPT4)
- IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
- QUIT
- +8 IF $GET(APCLRPT4)
- IF '$DATA(^DIBT(APCLSEAT,1,DFN))
- QUIT
- +9 ;not in community
- IF APCLCOMT="O"
- IF $$COMMRES^AUPNPAT(DFN,"I")'=APCLCOMT("ONE")
- QUIT
- +10 ;not in comm taxonomy
- IF APCLCOMT="S"
- SET X=$$COMMRES^AUPNPAT(DFN,"E")
- IF '$DATA(APCLTAX(X))
- QUIT
- +11 DO PROC1
- +12 QUIT
- End DoDot:1
- +13 QUIT
- PROC1 ;
- +1 KILL APCLG
- SET %=DFN_"^ALL VISITS;DURING "_APCLBD_"-"_APCLED
- SET E=$$START1^APCLDF(%,"APCLG(")
- +2 SET APCLE=0
- FOR
- SET APCLE=$ORDER(APCLG(APCLE))
- IF APCLE'=+APCLE
- QUIT
- Begin DoDot:1
- +3 SET APCLVIEN=$PIECE(APCLG(APCLE),U,5)
- +4 IF 'APCLVIEN
- QUIT
- +5 SET APCLDATE=$PIECE(APCLG(APCLE),U,1)
- +6 IF 'APCLEXBH
- SET C=$$CLINIC^APCLV(APCLVIEN,"C")
- IF C=14!(C=45)!(C=48)
- QUIT
- +7 IF APCLLOCT="O"
- IF $PIECE(^AUPNVSIT(APCLVIEN,0),U,6)'=APCLLOCT("ONE")
- QUIT
- +8 IF APCLLOCT="S"
- IF $$VALI^XBDIQ1(9999999.06,$PIECE(^AUPNVSIT(APCLVIEN,0),U,6),.05)'=APCLLOCT("SU")
- QUIT
- PEXS SET APCLEIEN=0
- FOR
- SET APCLEIEN=$ORDER(^AUPNVXAM("AD",APCLVIEN,APCLEIEN))
- IF APCLEIEN'=+APCLEIEN
- QUIT
- Begin DoDot:2
- +1 IF '$DATA(^AUPNVXAM(APCLEIEN,0))
- QUIT
- +2 SET R=$PIECE(^AUPNVXAM(APCLEIEN,0),U,1)
- +3 IF $PIECE($GET(^AUTTEXAM(+R,0)),U,2)'=35
- QUIT
- +4 SET APCLRES=$$VAL^XBDIQ1(9000010.13,APCLEIEN,.04)
- IF APCLRES["REFUSED"
- SET APCLRES="REFUSED SCREENING"
- IF APCLRES["NEGATIVE"
- SET APCLRES="NEGATIVE"
- +5 SET ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$PPV(APCLVIEN)_U_APCLRES_U_$$VAL^XBDIQ1(9000010.13,APCLEIEN,81101)_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- +6 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
- +7 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLVIEN
- +8 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$SPRV(APCLEIEN)
- +9 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- +10 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="EXAM"
- End DoDot:2
- PMSRS ;
- +1 SET APCLEIEN=0
- FOR
- SET APCLEIEN=$ORDER(^AUPNVMSR("AD",APCLVIEN,APCLEIEN))
- IF APCLEIEN'=+APCLEIEN
- QUIT
- Begin DoDot:2
- +2 IF '$DATA(^AUPNVMSR(APCLEIEN,0))
- QUIT
- +3 ;ENTERED IN ERROR
- IF $PIECE($GET(^AUPNVMSR(APCLEIEN,2)),U,1)
- QUIT
- +4 SET R=$PIECE(^AUPNVMSR(APCLEIEN,0),U,1)
- +5 SET R=$PIECE($GET(^AUTTMSR(+R,0)),U,1)
- +6 IF R'="AUDC"
- IF R'="AUDT"
- IF R'="CRFT"
- QUIT
- +7 SET APCLRES=R_" "_$$VAL^XBDIQ1(9000010.01,APCLEIEN,.04)
- +8 SET ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$PPV(APCLVIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- +9 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
- +10 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLVIEN
- +11 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$MPRV(APCLEIEN)
- +12 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- +13 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="MSR"
- End DoDot:2
- PHF ;
- +1 SET APCLEIEN=0
- FOR
- SET APCLEIEN=$ORDER(^AUPNVHF("AD",APCLVIEN,APCLEIEN))
- IF APCLEIEN'=+APCLEIEN
- QUIT
- Begin DoDot:2
- +2 IF '$DATA(^AUPNVHF(APCLEIEN,0))
- QUIT
- +3 SET R=$PIECE(^AUPNVHF(APCLEIEN,0),U,1)
- +4 SET R=$$VAL^XBDIQ1(9999999.64,R,.01)
- +5 IF R'["CAGE "
- QUIT
- +6 SET APCLRES=R
- +7 SET ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$PPV(APCLVIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- +8 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
- +9 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLVIEN
- +10 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$HFPRV(APCLEIEN)
- +11 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- +12 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="HF"
- End DoDot:2
- PPVS ;
- +1 SET APCLEIEN=0
- FOR
- SET APCLEIEN=$ORDER(^AUPNVPOV("AD",APCLVIEN,APCLEIEN))
- IF APCLEIEN'=+APCLEIEN
- QUIT
- Begin DoDot:2
- +2 IF '$DATA(^AUPNVPOV(APCLEIEN,0))
- QUIT
- +3 SET R=$$VAL^XBDIQ1(9000010.07,APCLEIEN,.01)
- +4 IF R'="V79.1"
- QUIT
- +5 SET APCLRES=""
- +6 SET ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$PPV(APCLVIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- +7 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
- +8 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLVIEN
- +9 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$PVPRV(APCLEIEN)
- +10 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- +11 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="DX"
- End DoDot:2
- PPEDS ;
- +1 SET APCLEIEN=0
- FOR
- SET APCLEIEN=$ORDER(^AUPNVPED("AD",APCLVIEN,APCLEIEN))
- IF APCLEIEN'=+APCLEIEN
- QUIT
- Begin DoDot:2
- +2 IF '$DATA(^AUPNVPED(APCLEIEN,0))
- QUIT
- +3 SET R=$PIECE(^AUPNVPED(APCLEIEN,0),U,1)
- +4 SET R=$PIECE($GET(^AUTTEDT(+R,0)),U,2)
- +5 IF R'="AOD-SCR"
- IF R'="CD-SCR"
- QUIT
- +6 SET APCLRES=""
- +7 SET ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$PPV(APCLVIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- +8 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
- +9 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLVIEN
- +10 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$PEDPRV(APCLEIEN)
- +11 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- +12 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="PED"
- End DoDot:2
- PCPTS ;
- +1 SET APCLEIEN=0
- FOR
- SET APCLEIEN=$ORDER(^AUPNVCPT("AD",APCLVIEN,APCLEIEN))
- IF APCLEIEN'=+APCLEIEN
- QUIT
- Begin DoDot:2
- +2 IF '$DATA(^AUPNVCPT(APCLEIEN,0))
- QUIT
- +3 SET R=$PIECE(^AUPNVCPT(APCLEIEN,0),U)
- +4 IF '$$ICD^ATXAPI(R,$ORDER(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0)),1)
- QUIT
- +5 SET APCLRES=""
- +6 SET ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$PPV(APCLVIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- +7 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
- +8 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLVIEN
- +9 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$CPTPRV(APCLEIEN)
- +10 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- +11 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="CPT"
- End DoDot:2
- End DoDot:1
- PREF ;now go through refusals in pcc
- +1 SET APCLRIEN=0
- FOR
- SET APCLRIEN=$ORDER(^AUPNPREF("AC",DFN,APCLRIEN))
- IF APCLRIEN'=+APCLRIEN
- QUIT
- Begin DoDot:1
- +2 IF '$DATA(^AUPNPREF(APCLRIEN,0))
- QUIT
- +3 IF $PIECE(^AUPNPREF(APCLRIEN,0),U,5)'=9999999.15
- QUIT
- +4 IF $PIECE(^AUPNPREF(APCLRIEN,0),U,6)'=APCLEXC
- QUIT
- +5 SET APCLDATE=$PIECE(^AUPNPREF(APCLRIEN,0),U,3)
- +6 IF APCLDATE=""
- QUIT
- +7 IF APCLDATE>APCLED
- QUIT
- +8 IF APCLDATE<APCLBD
- QUIT
- +9 ;already got one from v exam on this date
- IF $DATA(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE))
- QUIT
- +10 ;S X=$O(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,0))
- +11 ;I X]"",X<APCLDATE K ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,X)
- +12 SET APCLRES=$$VAL^XBDIQ1(9000022,APCLRIEN,.07)
- IF APCLRES["REFUSED"
- SET APCLRES="REFUSED SCREENING"
- IF APCLRES["NEGATIVE"
- SET APCLRES="NEGATIVE"
- +13 SET ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="REF"_U_"UNKNOWN"_U_APCLRES_U_$$VAL^XBDIQ1(9000022,APCLRIEN,1101)_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLRIEN_U
- +14 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$PRVREF(APCLRIEN)
- +15 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- +16 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="EXAM"
- End DoDot:1
- BH ;now go through BH
- +1 ;not if user doesn't want to
- IF 'APCLEXBH
- QUIT
- +2 SET APCLSD=$$FMADD^XLFDT(APCLBD,-1)
- SET APCLSD=APCLSD_".9999"
- +3 FOR
- SET APCLSD=$ORDER(^AMHREC("AF",DFN,APCLSD))
- IF APCLSD'=+APCLSD!($PIECE(APCLSD,".")>APCLED)
- QUIT
- DO BH1
- +4 QUIT
- BH1 ;
- +1 SET APCLBIEN=0
- FOR
- SET APCLBIEN=$ORDER(^AMHREC("AF",DFN,APCLSD,APCLBIEN))
- IF APCLBIEN'=+APCLBIEN
- QUIT
- Begin DoDot:1
- +2 SET APCLDATE=$PIECE(APCLSD,".")
- +3 IF '$DATA(^AMHREC(APCLBIEN,0))
- QUIT
- +4 IF APCLLOCT="O"
- IF $PIECE(^AMHREC(APCLBIEN,0),U,4)'=APCLLOCT("ONE")
- QUIT
- +5 IF APCLLOCT="S"
- IF $$VALI^XBDIQ1(9999999.06,$PIECE(^AMHREC(APCLBIEN,0),U,4),.05)'=APCLLOCT("SU")
- QUIT
- +6 ;already got one from PCC on this date
- IF $DATA(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE))
- QUIT
- +7 ;S X=$O(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,0))
- +8 ;I X]"",X<APCLDATE K ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,X)
- +9 SET APCLRES=$$VAL^XBDIQ1(9002011,APCLBIEN,1403)
- +10 IF APCLRES=""
- GOTO BMSR
- +11 IF APCLRES["REFUSED"
- SET APCLRES="REFUSED SCREENING"
- IF APCLRES["NEGATIVE"
- SET APCLRES="NEGATIVE"
- +12 SET ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="BH"_U_$$BHPPNAME(APCLBIEN)_U_APCLRES_U_$$VAL^XBDIQ1(9002011,APCLBIEN,1601)_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLBIEN
- +13 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
- +14 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLBIEN
- +15 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$SELECT($PIECE($GET(^AMHREC(APCLBIEN,14)),U,2):$$VAL^XBDIQ1(9002011,APCLBIEN,1404),1:"UNKNOWN")
- +16 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- BMSR ;
- +1 SET APCLEIEN=0
- FOR
- SET APCLEIEN=$ORDER(^AMHRMSR("AD",APCLBIEN,APCLEIEN))
- IF APCLEIEN'=+APCLEIEN
- QUIT
- Begin DoDot:2
- +2 IF '$DATA(^AMHRMSR(APCLEIEN,0))
- QUIT
- +3 SET R=$PIECE(^AMHRMSR(APCLEIEN,0),U,1)
- +4 SET R=$PIECE($GET(^AUTTMSR(+R,0)),U,1)
- +5 IF R'="AUDC"
- IF R'="AUDT"
- IF R'="CRFT"
- QUIT
- +6 SET APCLRES=R_" "_$$VAL^XBDIQ1(9002011.12,APCLEIEN,.04)
- +7 SET ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="BH"_U_$$BHPPNAME(APCLBIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- +8 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
- +9 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLBIEN
- +10 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$BHPPNAME(APCLBIEN)
- +11 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- +12 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="MSR"
- End DoDot:2
- BHF ;
- +1 SET APCLEIEN=0
- FOR
- SET APCLEIEN=$ORDER(^AMHRHF("AD",APCLBIEN,APCLEIEN))
- IF APCLEIEN'=+APCLEIEN
- QUIT
- Begin DoDot:2
- +2 IF '$DATA(^AMHRHF(APCLEIEN,0))
- QUIT
- +3 SET R=$PIECE(^AMHRHF(APCLEIEN,0),U,1)
- +4 SET R=$$VAL^XBDIQ1(9999999.64,R,.01)
- +5 IF R'["CAGE "
- QUIT
- +6 SET APCLRES=R
- +7 SET ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$BHPPNAME(APCLBIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- +8 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
- +9 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLBIEN
- +10 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$BHPPNAME(APCLBIEN)
- +11 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- +12 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="HF"
- End DoDot:2
- BPVS ;
- +1 SET APCLEIEN=0
- FOR
- SET APCLEIEN=$ORDER(^AMHRPRO("AD",APCLBIEN,APCLEIEN))
- IF APCLEIEN'=+APCLEIEN
- QUIT
- Begin DoDot:2
- +2 IF '$DATA(^AMHRPRO(APCLEIEN,0))
- QUIT
- +3 SET R=$$VAL^XBDIQ1(9002011.01,APCLEIEN,.01)
- +4 IF R'="29.1"
- QUIT
- +5 SET APCLRES=""
- +6 SET ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$BHPPNAME(APCLBIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- +7 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
- +8 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLBIEN
- +9 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$BHPPNAME(APCLBIEN)
- +10 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- +11 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="DX"
- End DoDot:2
- BPEDS ;
- +1 SET APCLEIEN=0
- FOR
- SET APCLEIEN=$ORDER(^AMHREDU("AD",APCLBIEN,APCLEIEN))
- IF APCLEIEN'=+APCLEIEN
- QUIT
- Begin DoDot:2
- +2 IF '$DATA(^AMHREDU(APCLEIEN,0))
- QUIT
- +3 SET R=$PIECE(^AMHREDU(APCLEIEN,0),U,1)
- +4 SET R=$PIECE($GET(^AUTTEDT(+R,0)),U,2)
- +5 IF R'="AOD-SCR"
- IF R'="CD-SCR"
- QUIT
- +6 SET APCLRES=""
- +7 SET ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$BHPPNAME(APCLBIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- +8 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
- +9 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLBIEN
- +10 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$BHPPNAME(APCLBIEN)
- +11 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- +12 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="PED"
- End DoDot:2
- BCPTS ;
- +1 SET APCLEIEN=0
- FOR
- SET APCLEIEN=$ORDER(^AMHRPROC("AD",APCLBIEN,APCLEIEN))
- IF APCLEIEN'=+APCLEIEN
- QUIT
- Begin DoDot:2
- +2 IF '$DATA(^AMHRPROC(APCLEIEN,0))
- QUIT
- +3 SET R=$PIECE(^AMHRPROC(APCLEIEN,0),U)
- +4 IF '$$ICD^ATXAPI(R,$ORDER(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0)),1)
- QUIT
- +5 SET APCLRES=""
- +6 SET ^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="EX"_U_$$BHPPNAME(APCLBIEN)_U_APCLRES_U_""_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLEIEN
- +7 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
- +8 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLBIEN
- +9 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$BHPPNAME(APCLBIEN)
- +10 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
- +11 SET $PIECE(^XTMP("APCLAL1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,18)="CPT"
- End DoDot:2
- End DoDot:1
- +12 QUIT
- +13 ;
- BHPPNAME(R) ;EP primary provider internal # from 200
- +1 NEW %,%1
- +2 SET %=0
- SET %1=""
- FOR
- SET %=$ORDER(^AMHRPROV("AD",R,%))
- IF %'=+%
- QUIT
- IF $PIECE(^AMHRPROV(%,0),U,4)="P"
- SET %1=$PIECE(^AMHRPROV(%,0),U)
- SET %1=$PIECE($GET(^VA(200,%1,0)),U)
- +3 IF %1]""
- QUIT %1
- +4 QUIT "UNKNOWN"
- SPRV(E) ;
- +1 IF $PIECE($GET(^AUPNVXAM(E,12)),U,4)
- QUIT $$VAL^XBDIQ1(9000010.13,E,1204)
- +2 QUIT "UNKNOWN"
- PRVREF(R) ;
- +1 IF $PIECE($GET(^AUPNPREF(R,12)),U,4)]""
- QUIT $$VAL^XBDIQ1(9000022,R,1204)
- +2 QUIT "UNKNOWN"
- PPV(V) ;
- +1 NEW %
- +2 SET %=$$PRIMPROV^APCLV(V)
- +3 IF %=-1
- QUIT "UNKNOWN"
- +4 IF %]""
- QUIT %
- +5 QUIT "UNKNOWN"
- CTR(X,Y) ;EP - Center X in a field Y wide.
- +1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
- +2 ;----------
- EOP ;EP - End of page.
- +1 IF $EXTRACT(IOST)'="C"
- QUIT
- +2 IF IO'=IO(0)
- QUIT
- +3 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
- QUIT
- +4 NEW DIR
- +5 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
- +6 WRITE !
- +7 SET DIR("A")="End of Report. Press Enter"
- SET DIR(0)="E"
- DO ^DIR
- +8 QUIT
- +9 ;----------
- USR() ;EP - Return name of current user from ^VA(200.
- +1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
- +2 ;----------
- LOC() ;EP - Return location name from file 4 based on DUZ(2).
- +1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
- +2 ;----------
- +3 ;
- MPRV(E) ;
- +1 IF $PIECE($GET(^AUPNVMSR(E,12)),U,4)
- QUIT $$VAL^XBDIQ1(9000010.01,E,1204)
- +2 QUIT "UNKNOWN"
- HFPRV(E) ;
- +1 IF $PIECE($GET(^AUPNVHF(E,12)),U,4)
- QUIT $$VAL^XBDIQ1(9000010.22,E,1204)
- +2 QUIT "UNKNOWN"
- PVPRV(E) ;
- +1 IF $PIECE($GET(^AUPNVPOV(E,12)),U,4)
- QUIT $$VAL^XBDIQ1(9000010.07,E,1204)
- +2 QUIT "UNKNOWN"
- PEDPRV(E) ;
- +1 IF $PIECE($GET(^AUPNVPED(E,12)),U,4)
- QUIT $$VAL^XBDIQ1(9000010.16,E,1204)
- +2 QUIT "UNKNOWN"
- CPTPRV(E) ;
- +1 IF $PIECE($GET(^AUPNVCPT(E,12)),U,4)
- QUIT $$VAL^XBDIQ1(9000010.18,E,1204)
- +2 QUIT "UNKNOWN"
