APCLDV1 ; IHS/CMI/LAB - list refusals ;
;;2.0;IHS PCC SUITE;**8**;MAY 14, 2009;Build 2
;
;
INFORM ;
W !,$$CTR($$USR)
W !,$$LOC()
W !!,$$CTR("TALLY AND LISTING OF PATIENT'S RECEIVING IPV SCREENING,INCLUDING REFUSALS",80)
W !!,"This report will tally and optionally list all patients who have had "
W !,"IPV screening (Exam code 34) or a refusal documented in the time frame"
W !,"specified by the user."
W !,"This report will tally the patients by age, gender, result, provider (either"
W !,"exam provider, if available, or primary provider on the visit), and date of"
W !,"screening/refusal."
W !," Notes: "
W !?10,"- the last screening/refusal for each patient is used. If a patient"
W !?10," was screened more than once in the time period, only the latest"
W !?10," is used in this report."
W !?10,"- this report will optionally, look at both PCC and the Behavioral"
W !?10," Health databases for evidence of screening/refusal"
W !
D XIT
S APCLEXC=$O(^AUTTEXAM("C",34,0))
I 'APCLEXC W !!,"Exam code 34 is missing from the EXAM table. Cannot run report.",! H 3 D XIT Q
;
DATES K APCLED,APCLBD
W !,"Please enter the date range during which the screening was done.",!,"To get all screenings ever put in a long date range like 01/01/1980 ",!,"to the present date.",!
K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Date for Screening"
D ^DIR Q:Y<1 S APCLBD=Y
K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Date for Screening"
D ^DIR Q:Y<1 S APCLED=Y
;
I APCLED<APCLBD D G DATES
. W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
;
TALLY ;which items to tally
K APCLTALL
W !!,"Please select which items you wish to tally on this report:",!
W !?3,"0) Do not include any Tallies",?40,"5) Primary Provider of Visit"
W !?3,"1) Result of Screening",?40,"6) Designated Primary Care Provider"
W !?3,"2) Gender",?40,"7) Clinic"
W !?3,"3) Age of Patient",?40,"8) Date of Screening"
W !?3,"4) Provider who Screened"
K DIR S DIR(0)="L^0:8",DIR("A")="Which items should be tallied",DIR("B")="" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G DATES
I Y="" G DATES
S APCLTALL=Y
S A=Y,C="" F I=1:1 S C=$P(A,",",I) Q:C="" S APCLTALL(C)=""
EXCL ;
S APCLEXBH=""
W !!,"Would you like to include screenings done in the behavioral health clinics: "
W !,"Mental Health (14); Alcohol and Substance Abuse (43); Medical"
W !,"Social Services (48); Behavioral Health (C4) "
S DIR(0)="Y",DIR("A")="and Telebehavioral Health (C9)",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G DATES
S APCLEXBH=Y
FAC ;
K APCLQ
S APCLLOCT=""
S DIR(0)="S^A:ALL Locations/Facilities;S:One SERVICE UNIT'S Locations/Facilities;O:ONE Location/Facility",DIR("A")="Include Visits to Which Location/Facilities",DIR("B")="A"
S DIR("A")="Include screenings done at which facilities",DIR("B")="O" K DA D ^DIR K DIR,DA
G:$D(DIRUT) EXCL
S APCLLOCT=Y
I APCLLOCT="A" G COMM
D @APCLLOCT
G:$D(APCLQ) FAC
COMM ;
K APCLQ
S APCLCOMT=""
W !!,"You can just include patients living in certain communities",!,"or include all patients regardless of where they live."
S DIR(0)="S^A:ALL Patient Communitiess;S:Selected Set (taxonomy) of Communities;O:ONE Community",DIR("A")="Include Visits to Which Location/Facilities",DIR("B")="A"
S DIR("A")="Include screenings done at which facilities",DIR("B")="O" K DA D ^DIR K DIR,DA
G:$D(DIRUT) FAC
S APCLCOMT=Y
I APCLCOMT="A" G LIST
D @(APCLCOMT_"C")
G:$D(APCLQ) COMM
LIST ;
S APCLLIST=""
W !
S DIR(0)="Y",DIR("A")="Would you like to include a list of patients screened",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G DATES
S APCLLIST=Y
I 'APCLLIST G ZIS
LIST1 ;
S APCLSORT=""
W !
S DIR(0)="S^H:Health Record Number;N:Patient Name;P:Provider who screened;C:Clinic;R:Result of Exam;D:Date Screened;A:Age of Patient at Screening;G:Gender of Patient;T:Terminal Digit HRN"
S DIR("A")="How would you like the list to be sorted",DIR("B")="H"
KILL DA D ^DIR KILL DIR
I $D(DIRUT) G LIST
S APCLSORT=Y
DP ;
S APCLDP=""
W !
S DIR(0)="Y",DIR("A")="Display the Patient's Designated Providers on the list",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G LIST
S APCLDP=Y
ZIS ;
DEMO ;
D DEMOCHK^APCLUTL(.APCLDEMO)
I APCLDEMO=-1 G LIST
S XBRP="PRINT^APCLDV1P",XBRC="PROC^APCLDV1",XBRX="XIT^APCLDV1",XBNS="APCL"
D ^XBDBQUE
D XIT
Q
XIT ;
D EN^XBVK("APCL")
D ^XBFMK
Q
O ;EP one location
S DIC="^AUTTLOC(",DIC(0)="AEMQ",DIC("A")="Which LOCATION: " D ^DIC K DIC
I Y=-1 S APCLQ="" Q
S APCLLOCT("ONE")=+Y
Q
S ;EP all LOCATIONS within APCLSU su
S DIC="^AUTTSU(",DIC("B")=$$VAL^XBDIQ1(9999999.06,DUZ(2),.05),DIC(0)="AEMQ",DIC("A")="Which SERVICE UNIT: " D ^DIC K DIC
I Y=-1 S APCLQ="" Q
S APCLLOCT("SU")=+Y
Q
OC ;EP one COMMUNITY
S DIC="^AUTTCOM(",DIC(0)="AEMQ",DIC("A")="Which COMMUNITY: " D ^DIC K DIC
I Y=-1 S APCLQ="" Q
S APCLCOMT("ONE")=+Y
Q
SC ;EP all communities within TAXONOMY
D ^XBFMK
S DIC("S")="I $P(^(0),U,15)=9999999.05",DIC="^ATXAX(",DIC(0)="AEMQ",DIC("A")="Enter the Name of the Community Taxonomy: "
;S B=$P($G(^BGPSITE(DUZ(2),0)),U,5) I B S DIC("B")=$P(^ATXAX(B,0),U)
D ^DIC K DIC
I Y=-1 S APCLQ="" Q
S APCLCOMT("SU")=+Y
COM1 S X=0
F S X=$O(^ATXAX(+Y,21,X)) Q:'X D
.S APCLTAX($P(^ATXAX(+Y,21,X,0),U))=""
.Q
I '$D(APCLTAX) W !!,"There are no communities in that taxonomy." S APCLQ="" Q
Q
PROC ;
S APCLCNT=0
S APCLH=$H,APCLJ=$J
K ^XTMP("APCLDV1",APCLJ,APCLH)
D XTMP^APCLOSUT("APCLDV1","IPV SCREENING REPORT")
;go through exam IPV, then through AUPNPREF for refusals
S APCLEIEN=0 F S APCLEIEN=$O(^AUPNVXAM("B",APCLEXC,APCLEIEN)) Q:APCLEIEN'=+APCLEIEN D
.Q:'$D(^AUPNVXAM(APCLEIEN,0))
.S DFN=$P(^AUPNVXAM(APCLEIEN,0),U,2)
.Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
.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
.S APCLVIEN=$P(^AUPNVXAM(APCLEIEN,0),U,3)
.Q:'APCLVIEN
.S APCLDATE=$P($P($G(^AUPNVSIT(APCLVIEN,0)),U),".")
.Q:APCLDATE=""
.Q:APCLDATE>APCLED
.Q:APCLDATE<APCLBD
.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
.I 'APCLEXBH S C=$$CLINIC^APCLV(APCLVIEN,"C") I C=14!(C=43)!(C=48)!(C="C4")!(C="C9") Q
.;S X=$O(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,0))
.;I X]"",X<APCLDATE K ^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,X)
.S APCLRES=$$VAL^XBDIQ1(9000010.13,APCLEIEN,.04) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
.S ^XTMP("APCLDV1",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("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
.S $P(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLVIEN
.S $P(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$SPRV(APCLEIEN)
.S $P(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
;now go through refusals in pcc
S APCLRIEN=0 F S APCLRIEN=$O(^AUPNPREF(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
.S DFN=$P(^AUPNPREF(APCLRIEN,0),U,2)
.Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
.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
.Q:$D(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE)) ;already got one from v exam on this date
.;S X=$O(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,0))
.;I X]"",X<APCLDATE K ^XTMP("APCLDV1",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("APCLDV1",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("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$PRVREF(APCLRIEN)
.S $P(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
;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("B",APCLSD)) Q:APCLSD'=+APCLSD!($P(APCLSD,".")>APCLED) D
.S APCLBIEN=0 F S APCLBIEN=$O(^AMHREC("B",APCLSD,APCLBIEN)) Q:APCLBIEN'=+APCLBIEN D
..S APCLDATE=$P(APCLSD,".")
..Q:'$D(^AMHREC(APCLBIEN,0))
..Q:$P($G(^AMHREC(APCLBIEN,14)),U)=""
..Q:APCLDATE>APCLED
..Q:APCLDATE<APCLBD
..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
..S DFN=$P(^AMHREC(APCLBIEN,0),U,8) Q:'DFN
..Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
..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
..Q:$D(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE)) ;already got one from PCC on this date
..;S X=$O(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,0))
..;I X]"",X<APCLDATE K ^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,X)
..S APCLRES=$$VAL^XBDIQ1(9002011,APCLBIEN,1401) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
..S ^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="BH"_U_$$BHPPNAME(APCLBIEN)_U_APCLRES_U_$$VAL^XBDIQ1(9002011,APCLBIEN,1501)_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLBIEN
..S $P(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
..S $P(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLBIEN
..S $P(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$S($P($G(^AMHREC(APCLBIEN,14)),U,2):$$VAL^XBDIQ1(9002011,APCLBIEN,1402),1:"UNKNOWN")
..S $P(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
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) ;
;get 1204 if it exists, otherwise take 1202
I $P($G(^AUPNVXAM(E,12)),U,4) Q $$VAL^XBDIQ1(9000010.13,E,1204)
I $P($G(^AUPNVXAM(E,12)),U,2) Q $$VAL^XBDIQ1(9000010.13,E,1202)
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 %]"" 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")
;----------
APCLDV1 ; IHS/CMI/LAB - list refusals ;
+1 ;;2.0;IHS PCC SUITE;**8**;MAY 14, 2009;Build 2
+2 ;
+3 ;
INFORM ;
+1 WRITE !,$$CTR($$USR)
+2 WRITE !,$$LOC()
+3 WRITE !!,$$CTR("TALLY AND LISTING OF PATIENT'S RECEIVING IPV SCREENING,INCLUDING REFUSALS",80)
+4 WRITE !!,"This report will tally and optionally list all patients who have had "
+5 WRITE !,"IPV screening (Exam code 34) or a refusal documented in the time frame"
+6 WRITE !,"specified by the user."
+7 WRITE !,"This report will tally the patients by age, gender, result, provider (either"
+8 WRITE !,"exam provider, if available, or primary provider on the visit), and date of"
+9 WRITE !,"screening/refusal."
+10 WRITE !," Notes: "
+11 WRITE !?10,"- the last screening/refusal for each patient is used. If a patient"
+12 WRITE !?10," was screened more than once in the time period, only the latest"
+13 WRITE !?10," is used in this report."
+14 WRITE !?10,"- this report will optionally, look at both PCC and the Behavioral"
+15 WRITE !?10," Health databases for evidence of screening/refusal"
+16 WRITE !
+17 DO XIT
+18 SET APCLEXC=$ORDER(^AUTTEXAM("C",34,0))
+19 IF 'APCLEXC
WRITE !!,"Exam code 34 is missing from the EXAM table. Cannot run report.",!
HANG 3
DO XIT
QUIT
+20 ;
DATES KILL APCLED,APCLBD
+1 WRITE !,"Please enter the date range during which the screening was done.",!,"To get all screenings ever put in a long date range like 01/01/1980 ",!,"to the present date.",!
+2 KILL DIR
WRITE !
SET DIR(0)="DO^::EXP"
SET DIR("A")="Enter Beginning Date for Screening"
+3 DO ^DIR
IF Y<1
QUIT
SET APCLBD=Y
+4 KILL DIR
SET DIR(0)="DO^:DT:EXP"
SET DIR("A")="Enter Ending Date for Screening"
+5 DO ^DIR
IF Y<1
QUIT
SET APCLED=Y
+6 ;
+7 IF APCLED<APCLBD
Begin DoDot:1
+8 WRITE !!,$CHAR(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
End DoDot:1
GOTO DATES
+9 ;
TALLY ;which items to tally
+1 KILL APCLTALL
+2 WRITE !!,"Please select which items you wish to tally on this report:",!
+3 WRITE !?3,"0) Do not include any Tallies",?40,"5) Primary Provider of Visit"
+4 WRITE !?3,"1) Result of Screening",?40,"6) Designated Primary Care Provider"
+5 WRITE !?3,"2) Gender",?40,"7) Clinic"
+6 WRITE !?3,"3) Age of Patient",?40,"8) Date of Screening"
+7 WRITE !?3,"4) Provider who Screened"
+8 KILL DIR
SET DIR(0)="L^0:8"
SET DIR("A")="Which items should be tallied"
SET DIR("B")=""
KILL DA
DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)
GOTO DATES
+10 IF Y=""
GOTO DATES
+11 SET APCLTALL=Y
+12 SET A=Y
SET C=""
FOR I=1:1
SET C=$PIECE(A,",",I)
IF C=""
QUIT
SET APCLTALL(C)=""
EXCL ;
+1 SET APCLEXBH=""
+2 WRITE !!,"Would you like to include screenings done in the behavioral health clinics: "
+3 WRITE !,"Mental Health (14); Alcohol and Substance Abuse (43); Medical"
+4 WRITE !,"Social Services (48); Behavioral Health (C4) "
+5 SET DIR(0)="Y"
SET DIR("A")="and Telebehavioral Health (C9)"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
GOTO DATES
+7 SET APCLEXBH=Y
FAC ;
+1 KILL APCLQ
+2 SET APCLLOCT=""
+3 SET DIR(0)="S^A:ALL Locations/Facilities;S:One SERVICE UNIT'S Locations/Facilities;O:ONE Location/Facility"
SET DIR("A")="Include Visits to Which Location/Facilities"
SET DIR("B")="A"
+4 SET DIR("A")="Include screenings done at which facilities"
SET DIR("B")="O"
KILL DA
DO ^DIR
KILL DIR,DA
+5 IF $DATA(DIRUT)
GOTO EXCL
+6 SET APCLLOCT=Y
+7 IF APCLLOCT="A"
GOTO COMM
+8 DO @APCLLOCT
+9 IF $DATA(APCLQ)
GOTO FAC
COMM ;
+1 KILL APCLQ
+2 SET APCLCOMT=""
+3 WRITE !!,"You can just include patients living in certain communities",!,"or include all patients regardless of where they live."
+4 SET DIR(0)="S^A:ALL Patient Communitiess;S:Selected Set (taxonomy) of Communities;O:ONE Community"
SET DIR("A")="Include Visits to Which Location/Facilities"
SET DIR("B")="A"
+5 SET DIR("A")="Include screenings done at which facilities"
SET DIR("B")="O"
KILL DA
DO ^DIR
KILL DIR,DA
+6 IF $DATA(DIRUT)
GOTO FAC
+7 SET APCLCOMT=Y
+8 IF APCLCOMT="A"
GOTO LIST
+9 DO @(APCLCOMT_"C")
+10 IF $DATA(APCLQ)
GOTO COMM
LIST ;
+1 SET APCLLIST=""
+2 WRITE !
+3 SET DIR(0)="Y"
SET DIR("A")="Would you like to include a list of patients screened"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO DATES
+5 SET APCLLIST=Y
+6 IF 'APCLLIST
GOTO ZIS
LIST1 ;
+1 SET APCLSORT=""
+2 WRITE !
+3 SET DIR(0)="S^H:Health Record Number;N:Patient Name;P:Provider who screened;C:Clinic;R:Result of Exam;D:Date Screened;A:Age of Patient at Screening;G:Gender of Patient;T:Terminal Digit HRN"
+4 SET DIR("A")="How would you like the list to be sorted"
SET DIR("B")="H"
+5 KILL DA
DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
GOTO LIST
+7 SET APCLSORT=Y
DP ;
+1 SET APCLDP=""
+2 WRITE !
+3 SET DIR(0)="Y"
SET DIR("A")="Display the Patient's Designated Providers on the list"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO LIST
+5 SET APCLDP=Y
ZIS ;
DEMO ;
+1 DO DEMOCHK^APCLUTL(.APCLDEMO)
+2 IF APCLDEMO=-1
GOTO LIST
+3 SET XBRP="PRINT^APCLDV1P"
SET XBRC="PROC^APCLDV1"
SET XBRX="XIT^APCLDV1"
SET XBNS="APCL"
+4 DO ^XBDBQUE
+5 DO XIT
+6 QUIT
XIT ;
+1 DO EN^XBVK("APCL")
+2 DO ^XBFMK
+3 QUIT
O ;EP one location
+1 SET DIC="^AUTTLOC("
SET DIC(0)="AEMQ"
SET DIC("A")="Which LOCATION: "
DO ^DIC
KILL DIC
+2 IF Y=-1
SET APCLQ=""
QUIT
+3 SET APCLLOCT("ONE")=+Y
+4 QUIT
S ;EP all LOCATIONS within APCLSU su
+1 SET DIC="^AUTTSU("
SET DIC("B")=$$VAL^XBDIQ1(9999999.06,DUZ(2),.05)
SET DIC(0)="AEMQ"
SET DIC("A")="Which SERVICE UNIT: "
DO ^DIC
KILL DIC
+2 IF Y=-1
SET APCLQ=""
QUIT
+3 SET APCLLOCT("SU")=+Y
+4 QUIT
OC ;EP one COMMUNITY
+1 SET DIC="^AUTTCOM("
SET DIC(0)="AEMQ"
SET DIC("A")="Which COMMUNITY: "
DO ^DIC
KILL DIC
+2 IF Y=-1
SET APCLQ=""
QUIT
+3 SET APCLCOMT("ONE")=+Y
+4 QUIT
SC ;EP all communities within TAXONOMY
+1 DO ^XBFMK
+2 SET DIC("S")="I $P(^(0),U,15)=9999999.05"
SET DIC="^ATXAX("
SET DIC(0)="AEMQ"
SET DIC("A")="Enter the Name of the Community Taxonomy: "
+3 ;S B=$P($G(^BGPSITE(DUZ(2),0)),U,5) I B S DIC("B")=$P(^ATXAX(B,0),U)
+4 DO ^DIC
KILL DIC
+5 IF Y=-1
SET APCLQ=""
QUIT
+6 SET APCLCOMT("SU")=+Y
COM1 SET X=0
+1 FOR
SET X=$ORDER(^ATXAX(+Y,21,X))
IF 'X
QUIT
Begin DoDot:1
+2 SET APCLTAX($PIECE(^ATXAX(+Y,21,X,0),U))=""
+3 QUIT
End DoDot:1
+4 IF '$DATA(APCLTAX)
WRITE !!,"There are no communities in that taxonomy."
SET APCLQ=""
QUIT
+5 QUIT
PROC ;
+1 SET APCLCNT=0
+2 SET APCLH=$HOROLOG
SET APCLJ=$JOB
+3 KILL ^XTMP("APCLDV1",APCLJ,APCLH)
+4 DO XTMP^APCLOSUT("APCLDV1","IPV SCREENING REPORT")
+5 ;go through exam IPV, then through AUPNPREF for refusals
+6 SET APCLEIEN=0
FOR
SET APCLEIEN=$ORDER(^AUPNVXAM("B",APCLEXC,APCLEIEN))
IF APCLEIEN'=+APCLEIEN
QUIT
Begin DoDot:1
+7 IF '$DATA(^AUPNVXAM(APCLEIEN,0))
QUIT
+8 SET DFN=$PIECE(^AUPNVXAM(APCLEIEN,0),U,2)
+9 IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
QUIT
+10 ;not in community
IF APCLCOMT="O"
IF $$COMMRES^AUPNPAT(DFN,"I")'=APCLCOMT("ONE")
QUIT
+11 ;not in comm taxonomy
IF APCLCOMT="S"
SET X=$$COMMRES^AUPNPAT(DFN,"E")
IF '$DATA(APCLTAX(X))
QUIT
+12 SET APCLVIEN=$PIECE(^AUPNVXAM(APCLEIEN,0),U,3)
+13 IF 'APCLVIEN
QUIT
+14 SET APCLDATE=$PIECE($PIECE($GET(^AUPNVSIT(APCLVIEN,0)),U),".")
+15 IF APCLDATE=""
QUIT
+16 IF APCLDATE>APCLED
QUIT
+17 IF APCLDATE<APCLBD
QUIT
+18 IF APCLLOCT="O"
IF $PIECE(^AUPNVSIT(APCLVIEN,0),U,6)'=APCLLOCT("ONE")
QUIT
+19 IF APCLLOCT="S"
IF $$VALI^XBDIQ1(9999999.06,$PIECE(^AUPNVSIT(APCLVIEN,0),U,6),.05)'=APCLLOCT("SU")
QUIT
+20 IF 'APCLEXBH
SET C=$$CLINIC^APCLV(APCLVIEN,"C")
IF C=14!(C=43)!(C=48)!(C="C4")!(C="C9")
QUIT
+21 ;S X=$O(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,0))
+22 ;I X]"",X<APCLDATE K ^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,X)
+23 SET APCLRES=$$VAL^XBDIQ1(9000010.13,APCLEIEN,.04)
IF APCLRES["REFUSED"
SET APCLRES="REFUSED SCREENING"
IF APCLRES["NEGATIVE"
SET APCLRES="NEGATIVE"
+24 SET ^XTMP("APCLDV1",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
+25 SET $PIECE(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
+26 SET $PIECE(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLVIEN
+27 SET $PIECE(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$SPRV(APCLEIEN)
+28 SET $PIECE(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
End DoDot:1
+29 ;now go through refusals in pcc
+30 SET APCLRIEN=0
FOR
SET APCLRIEN=$ORDER(^AUPNPREF(APCLRIEN))
IF APCLRIEN'=+APCLRIEN
QUIT
Begin DoDot:1
+31 IF '$DATA(^AUPNPREF(APCLRIEN,0))
QUIT
+32 IF $PIECE(^AUPNPREF(APCLRIEN,0),U,5)'=9999999.15
QUIT
+33 IF $PIECE(^AUPNPREF(APCLRIEN,0),U,6)'=APCLEXC
QUIT
+34 SET APCLDATE=$PIECE(^AUPNPREF(APCLRIEN,0),U,3)
+35 IF APCLDATE=""
QUIT
+36 IF APCLDATE>APCLED
QUIT
+37 IF APCLDATE<APCLBD
QUIT
+38 SET DFN=$PIECE(^AUPNPREF(APCLRIEN,0),U,2)
+39 IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
QUIT
+40 ;not in community
IF APCLCOMT="O"
IF $$COMMRES^AUPNPAT(DFN,"I")'=APCLCOMT("ONE")
QUIT
+41 ;not in comm taxonomy
IF APCLCOMT="S"
SET X=$$COMMRES^AUPNPAT(DFN,"E")
IF '$DATA(APCLTAX(X))
QUIT
+42 ;already got one from v exam on this date
IF $DATA(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE))
QUIT
+43 ;S X=$O(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,0))
+44 ;I X]"",X<APCLDATE K ^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,X)
+45 SET APCLRES=$$VAL^XBDIQ1(9000022,APCLRIEN,.07)
IF APCLRES["REFUSED"
SET APCLRES="REFUSED SCREENING"
IF APCLRES["NEGATIVE"
SET APCLRES="NEGATIVE"
+46 SET ^XTMP("APCLDV1",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
+47 SET $PIECE(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$$PRVREF(APCLRIEN)
+48 SET $PIECE(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
End DoDot:1
+49 ;now go through BH
+50 ;not if user doesn't want to
IF 'APCLEXBH
QUIT
+51 SET APCLSD=$$FMADD^XLFDT(APCLBD,-1)
SET APCLSD=APCLSD_".9999"
+52 FOR
SET APCLSD=$ORDER(^AMHREC("B",APCLSD))
IF APCLSD'=+APCLSD!($PIECE(APCLSD,".")>APCLED)
QUIT
Begin DoDot:1
+53 SET APCLBIEN=0
FOR
SET APCLBIEN=$ORDER(^AMHREC("B",APCLSD,APCLBIEN))
IF APCLBIEN'=+APCLBIEN
QUIT
Begin DoDot:2
+54 SET APCLDATE=$PIECE(APCLSD,".")
+55 IF '$DATA(^AMHREC(APCLBIEN,0))
QUIT
+56 IF $PIECE($GET(^AMHREC(APCLBIEN,14)),U)=""
QUIT
+57 IF APCLDATE>APCLED
QUIT
+58 IF APCLDATE<APCLBD
QUIT
+59 IF APCLLOCT="O"
IF $PIECE(^AMHREC(APCLBIEN,0),U,4)'=APCLLOCT("ONE")
QUIT
+60 IF APCLLOCT="S"
IF $$VALI^XBDIQ1(9999999.06,$PIECE(^AMHREC(APCLBIEN,0),U,4),.05)'=APCLLOCT("SU")
QUIT
+61 SET DFN=$PIECE(^AMHREC(APCLBIEN,0),U,8)
IF 'DFN
QUIT
+62 IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
QUIT
+63 ;not in community
IF APCLCOMT="O"
IF $$COMMRES^AUPNPAT(DFN,"I")'=APCLCOMT("ONE")
QUIT
+64 ;not in comm taxonomy
IF APCLCOMT="S"
SET X=$$COMMRES^AUPNPAT(DFN,"E")
IF '$DATA(APCLTAX(X))
QUIT
+65 ;already got one from PCC on this date
IF $DATA(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE))
QUIT
+66 ;S X=$O(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,0))
+67 ;I X]"",X<APCLDATE K ^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,X)
+68 SET APCLRES=$$VAL^XBDIQ1(9002011,APCLBIEN,1401)
IF APCLRES["REFUSED"
SET APCLRES="REFUSED SCREENING"
IF APCLRES["NEGATIVE"
SET APCLRES="NEGATIVE"
+69 SET ^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE)="BH"_U_$$BHPPNAME(APCLBIEN)_U_APCLRES_U_$$VAL^XBDIQ1(9002011,APCLBIEN,1501)_U_$$AGE^AUPNPAT(DFN,APCLDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_APCLDATE_U_APCLBIEN
+70 SET $PIECE(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,9)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
+71 SET $PIECE(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,15)=APCLBIEN
+72 SET $PIECE(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,16)=$SELECT($PIECE($GET(^AMHREC(APCLBIEN,14)),U,2):$$VAL^XBDIQ1(9002011,APCLBIEN,1402),1:"UNKNOWN")
+73 SET $PIECE(^XTMP("APCLDV1",APCLJ,APCLH,"PTS",DFN,APCLDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
End DoDot:2
End DoDot:1
+74 QUIT
+75 ;
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 ;get 1204 if it exists, otherwise take 1202
+2 IF $PIECE($GET(^AUPNVXAM(E,12)),U,4)
QUIT $$VAL^XBDIQ1(9000010.13,E,1204)
+3 IF $PIECE($GET(^AUPNVXAM(E,12)),U,2)
QUIT $$VAL^XBDIQ1(9000010.13,E,1202)
+4 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 %]""
QUIT %
+4 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 ;----------
