APCLDV5 ; 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 ALL VISITS W/IPV SCREENING",80)
W !,$$CTR("ONLY PATIENTS WHO ARE MEMBERS OF A USER DEFINED SEARCH TEMPLATE",80)
W !,$$CTR("ARE INCLUDED IN THIS REPORT",80)
W !!,"This report will tally and optionally list all visits on which "
W !,"IPV screening (Exam code 34) or a refusal was documented in the"
W !,"time frame specified by the user."
W !,"This report will tally the visits by age, gender, result, provider (either"
W !,"exam provider, if available, or primary provider on the visit), and date of"
W !,"screening/refusal."
W !," Note: "
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."
;
STMP ;
S APCLSEAT=""
W ! S DIC("S")="I $P(^(0),U,4)=9000001" S DIC="^DIBT(",DIC("A")="Enter Patient SEARCH TEMPLATE name: ",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DICR
I Y=-1 G DATES
S APCLSEAT=+Y
;
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^APCLDV1
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")^APCLDV1
G:$D(APCLQ) COMM
LIST ;
S APCLLIST=""
W !
S DIR(0)="Y",DIR("A")="Would you like to include a list of visits w/screening done",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
ZIS ;
S XBRP="PRINT^APCLDV5P",XBRC="PROC^APCLDV5",XBRX="XIT^APCLDV5",XBNS="APCL"
D ^XBDBQUE
D XIT
Q
XIT ;
D EN^XBVK("APCL")
D ^XBFMK
Q
PROC ;
S APCLCNT=0
S APCLH=$H,APCLJ=$J
K ^XTMP("APCLDV5",APCLJ,APCLH)
D XTMP^APCLOSUT("APCLDV5","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:DFN=""
.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
.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 APCLCNT=APCLCNT+1
.S APCLRES=$$VAL^XBDIQ1(9000010.13,APCLEIEN,.04) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
.S ^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT)="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_U_DFN
.S $P(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,10)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
.S $P(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,15)=APCLVIEN
.S $P(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,16)=$$SPRV(APCLEIEN)
.S $P(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
.S ^XTMP("APCLDV5",APCLJ,APCLH,"PTS",DFN,APCLDATE)=APCLCNT
;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:'$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
.S APCLRES=$$VAL^XBDIQ1(9000022,APCLRIEN,.07) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
.S APCLCNT=APCLCNT+1
.S ^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT)="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_DFN_U
.S $P(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,16)=$$PRVREF(APCLRIEN)
.S $P(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
.S ^XTMP("APCLDV5",APCLJ,APCLH,"PTS",DFN,APCLDATE)=APCLCNT
;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:'$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
..I $D(^XTMP("APCLDV5",APCLJ,APCLH,"PTS",DFN,APCLDATE)) Q
..S APCLCNT=APCLCNT+1
..S APCLRES=$$VAL^XBDIQ1(9002011,APCLBIEN,1401) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
..S ^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT)="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_U_DFN
..S $P(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,10)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
..S $P(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,15)=APCLBIEN
..S $P(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,16)=$$VAL^XBDIQ1(9002011,APCLBIEN,1402)
..S $P(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
..S ^XTMP("APCLDE2",APCLJ,APCLH,"PTS",DFN,APCLSD)=APCLCNT
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")
;----------
APCLDV5 ; 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 ALL VISITS W/IPV SCREENING",80)
+4 WRITE !,$$CTR("ONLY PATIENTS WHO ARE MEMBERS OF A USER DEFINED SEARCH TEMPLATE",80)
+5 WRITE !,$$CTR("ARE INCLUDED IN THIS REPORT",80)
+6 WRITE !!,"This report will tally and optionally list all visits on which "
+7 WRITE !,"IPV screening (Exam code 34) or a refusal was documented in the"
+8 WRITE !,"time frame specified by the user."
+9 WRITE !,"This report will tally the visits by age, gender, result, provider (either"
+10 WRITE !,"exam provider, if available, or primary provider on the visit), and date of"
+11 WRITE !,"screening/refusal."
+12 WRITE !," Note: "
+13 WRITE !?10,"- this report will optionally, look at both PCC and the Behavioral"
+14 WRITE !?10," Health databases for evidence of screening/refusal"
+15 WRITE !
+16 DO XIT
+17 SET APCLEXC=$ORDER(^AUTTEXAM("C",34,0))
+18 IF 'APCLEXC
WRITE !!,"Exam code 34 is missing from the EXAM table. Cannot run report.",!
HANG 3
DO XIT
QUIT
+19 ;
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 ;
STMP ;
+1 SET APCLSEAT=""
+2 WRITE !
SET DIC("S")="I $P(^(0),U,4)=9000001"
SET DIC="^DIBT("
SET DIC("A")="Enter Patient SEARCH TEMPLATE name: "
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DR,DICR
+3 IF Y=-1
GOTO DATES
+4 SET APCLSEAT=+Y
+5 ;
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^APCLDV1
+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")^APCLDV1
+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 visits w/screening done"
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
ZIS ;
+1 SET XBRP="PRINT^APCLDV5P"
SET XBRC="PROC^APCLDV5"
SET XBRX="XIT^APCLDV5"
SET XBNS="APCL"
+2 DO ^XBDBQUE
+3 DO XIT
+4 QUIT
XIT ;
+1 DO EN^XBVK("APCL")
+2 DO ^XBFMK
+3 QUIT
PROC ;
+1 SET APCLCNT=0
+2 SET APCLH=$HOROLOG
SET APCLJ=$JOB
+3 KILL ^XTMP("APCLDV5",APCLJ,APCLH)
+4 DO XTMP^APCLOSUT("APCLDV5","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 DFN=""
QUIT
+10 IF '$DATA(^DIBT(APCLSEAT,1,DFN))
QUIT
+11 ;not in community
IF APCLCOMT="O"
IF $$COMMRES^AUPNPAT(DFN,"I")'=APCLCOMT("ONE")
QUIT
+12 ;not in comm taxonomy
IF APCLCOMT="S"
SET X=$$COMMRES^AUPNPAT(DFN,"E")
IF '$DATA(APCLTAX(X))
QUIT
+13 SET APCLVIEN=$PIECE(^AUPNVXAM(APCLEIEN,0),U,3)
+14 IF 'APCLVIEN
QUIT
+15 SET APCLDATE=$PIECE($PIECE($GET(^AUPNVSIT(APCLVIEN,0)),U),".")
+16 IF APCLDATE=""
QUIT
+17 IF APCLDATE>APCLED
QUIT
+18 IF APCLDATE<APCLBD
QUIT
+19 IF APCLLOCT="O"
IF $PIECE(^AUPNVSIT(APCLVIEN,0),U,6)'=APCLLOCT("ONE")
QUIT
+20 IF APCLLOCT="S"
IF $$VALI^XBDIQ1(9999999.06,$PIECE(^AUPNVSIT(APCLVIEN,0),U,6),.05)'=APCLLOCT("SU")
QUIT
+21 IF 'APCLEXBH
SET C=$$CLINIC^APCLV(APCLVIEN,"C")
IF C=14!(C=43)!(C=48)!(C="C4")!(C="C9")
QUIT
+22 SET APCLCNT=APCLCNT+1
+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("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT)="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_U_DFN
+25 SET $PIECE(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,10)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
+26 SET $PIECE(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,15)=APCLVIEN
+27 SET $PIECE(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,16)=$$SPRV(APCLEIEN)
+28 SET $PIECE(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
+29 SET ^XTMP("APCLDV5",APCLJ,APCLH,"PTS",DFN,APCLDATE)=APCLCNT
End DoDot:1
+30 ;now go through refusals in pcc
+31 SET APCLRIEN=0
FOR
SET APCLRIEN=$ORDER(^AUPNPREF(APCLRIEN))
IF APCLRIEN'=+APCLRIEN
QUIT
Begin DoDot:1
+32 IF '$DATA(^AUPNPREF(APCLRIEN,0))
QUIT
+33 IF $PIECE(^AUPNPREF(APCLRIEN,0),U,5)'=9999999.15
QUIT
+34 IF $PIECE(^AUPNPREF(APCLRIEN,0),U,6)'=APCLEXC
QUIT
+35 SET APCLDATE=$PIECE(^AUPNPREF(APCLRIEN,0),U,3)
+36 IF APCLDATE=""
QUIT
+37 IF APCLDATE>APCLED
QUIT
+38 IF APCLDATE<APCLBD
QUIT
+39 SET DFN=$PIECE(^AUPNPREF(APCLRIEN,0),U,2)
+40 IF '$DATA(^DIBT(APCLSEAT,1,DFN))
QUIT
+41 ;not in community
IF APCLCOMT="O"
IF $$COMMRES^AUPNPAT(DFN,"I")'=APCLCOMT("ONE")
QUIT
+42 ;not in comm taxonomy
IF APCLCOMT="S"
SET X=$$COMMRES^AUPNPAT(DFN,"E")
IF '$DATA(APCLTAX(X))
QUIT
+43 SET APCLRES=$$VAL^XBDIQ1(9000022,APCLRIEN,.07)
IF APCLRES["REFUSED"
SET APCLRES="REFUSED SCREENING"
IF APCLRES["NEGATIVE"
SET APCLRES="NEGATIVE"
+44 SET APCLCNT=APCLCNT+1
+45 SET ^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT)="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_DFN_U
+46 SET $PIECE(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,16)=$$PRVREF(APCLRIEN)
+47 SET $PIECE(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
+48 SET ^XTMP("APCLDV5",APCLJ,APCLH,"PTS",DFN,APCLDATE)=APCLCNT
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 '$DATA(^DIBT(APCLSEAT,1,DFN))
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 IF $DATA(^XTMP("APCLDV5",APCLJ,APCLH,"PTS",DFN,APCLDATE))
QUIT
+66 SET APCLCNT=APCLCNT+1
+67 SET APCLRES=$$VAL^XBDIQ1(9002011,APCLBIEN,1401)
IF APCLRES["REFUSED"
SET APCLRES="REFUSED SCREENING"
IF APCLRES["NEGATIVE"
SET APCLRES="NEGATIVE"
+68 SET ^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT)="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_U_DFN
+69 SET $PIECE(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,10)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
+70 SET $PIECE(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,15)=APCLBIEN
+71 SET $PIECE(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,16)=$$VAL^XBDIQ1(9002011,APCLBIEN,1402)
+72 SET $PIECE(^XTMP("APCLDV5",APCLJ,APCLH,"VSTS",APCLCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
+73 SET ^XTMP("APCLDE2",APCLJ,APCLH,"PTS",DFN,APCLSD)=APCLCNT
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 ;----------
