APCLDV31 ; IHS/CMI/LAB - list IPV/DV screenings ;
;;2.0;IHS PCC SUITE;**8,10**;MAY 14, 2009;Build 88
;
;
PROC ;
S APCLCNT=0
S APCLH=$H,APCLJ=$J
K ^XTMP("APCLDV3",APCLJ,APCLH)
D XTMP^APCLOSUT("APCLDV3","IPV SCREENING REPORT")
;go through exam IPV, then through AUPNPREF for refusals
S DFN=0 F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN D
.Q:'$D(^DPT(DFN,0))
.Q:$P(^DPT(DFN,0),U,19) ;merged away
.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
.I APCLSEX'[$P(^DPT(DFN,0),U,2) Q ;not right gender
.I APCLDESP]"",$P(^AUPNPAT(DFN,0),U,14)'=APCLDESP Q ;not correct designated provider
.D GATHER
.Q
D GETSCR
Q
GATHER ;gather up all exams, refusals and bh in time period for patient in DFN
;if at least one match criteria then set ^xtmp($j,$h,"pts",dfn)=""
S APCLEIEN=0 F S APCLEIEN=$O(^AUPNVXAM("AC",DFN,APCLEIEN)) Q:APCLEIEN'=+APCLEIEN D
.Q:'$D(^AUPNVXAM(APCLEIEN,0))
.Q:$P(^AUPNVXAM(APCLEIEN,0),U)'=APCLEXC ;not ipv/dv
.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
.S X=$$AGE^AUPNPAT(DFN,APCLDATE)
.I $D(APCLAGET),X>$P(APCLAGET,"-",2) Q
.I $D(APCLAGET),X<$P(APCLAGET,"-",1) Q
.;clinic check
.I $D(APCLCLNT) S X=$P(^AUPNVSIT(APCLVIEN,0),U,8) Q:X="" Q:'$D(APCLCLNT(X))
.;bh exclude/include check
.I 'APCLEXBH S C=$$CLINIC^APCLV(APCLVIEN,"C") I C=14!(C=43)!(C=48)!(C="C4")!(C="C9") Q
.;result check
.S APCLRES=$$VAL^XBDIQ1(9000010.13,APCLEIEN,.04) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
.I APCLRES="NEGATIVE",'$D(APCLREST(1)) Q
.I APCLRES="PRESENT",'$D(APCLREST(2)) Q
.I APCLRES="PAST",'$D(APCLREST(3)) Q
.I APCLRES="",'$D(APCLREST(6)) Q
.;PRIMARY PROVIDER CHECK
.S X=$$PRIMPROV^APCLV(APCLVIEN,"I")
.I $D(APCLPROV),X="" Q ;want only certain primary providers on visit
.I $D(APCLPROV),APCLPROV'=X Q ;want one provider and it's not this one
.I APCLPPUN,X'="" Q ;want only unknown and this one has a primary provider
.S X=$P($G(^AUPNVXAM(APCLEIEN,12)),U,4)
.I $D(APCLSPRV),X="" Q ;want only certain SCR providers on visit
.I $D(APCLSPRV),APCLSPRV'=X Q ;want one provider and it's not this one
.I APCLSPUN,X'="" Q ;want only unknown and this one has a SCR provider
.S ^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN)=""
REF ;now go through refusals in pcc
;Q:$D(^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN)) ;already got one so no need to go on
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
.S X=$$AGE^AUPNPAT(DFN,APCLDATE)
.I $D(APCLAGET),X>$P(APCLAGET,"-",2) Q
.I $D(APCLAGET),X<$P(APCLAGET,"-",1) Q
.S APCLRES=$$VAL^XBDIQ1(9000022,APCLRIEN,.07) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING"
.I APCLRES["REFUSED",'$D(APCLREST(4)) Q ;do not want refusals
.I APCLRES["UNABLE",'$D(APCLREST(5)) Q ;do not want unables
.S X=$P($G(^AUPNPREF(APCLRIEN,12)),U,4)
.I $D(APCLSPRV),X="" Q ;want only certain SCR providers on visit
.I $D(APCLSPRV),APCLSPRV'=X Q ;want one provider and it's not this one
.I APCLSPUN,X'="" Q ;want only unknown and this one has a SCR provider
.S ^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN)=""
;Q:$D(^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN)) ;already got this patient so no need to go on
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
.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))
..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 X=$$AGE^AUPNPAT(DFN,APCLDATE)
..I $D(APCLAGET),X>$P(APCLAGET,"-",2) Q
..I $D(APCLAGET),X<$P(APCLAGET,"-",1) Q
..;clinic check
..I $D(APCLCLNT) S X=$P(^AMHREC(APCLBIEN,0),U,25) Q:X="" Q:'$D(APCLCLNT(X))
..;result check
..S APCLRES=$$VAL^XBDIQ1(9002011,APCLBIEN,1401) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
..I APCLRES="NEGATIVE",'$D(APCLREST(1)) Q
..I APCLRES="PRESENT",'$D(APCLREST(2)) Q
..I APCLRES="PAST",'$D(APCLREST(3)) Q
..I APCLRES["REFUSED",'$D(APCLREST(4)) Q ;do not want refusals
..I APCLRES["UNABLE",'$D(APCLREST(5)) Q ;do not want unables
..I APCLRES="",'$D(APCLREST(6)) Q
..;PRIMARY PROVIDER CHECK
..S X=$$BHPPIN(APCLBIEN)
..I $D(APCLPROV),X="" Q ;want only certain primary providers on visit
..I $D(APCLPROV),APCLPROV'=X Q ;want one provider and it's not this one
..I APCLPPUN,X'="" Q ;want only unknown and this one has a primary provider
..S X=$P($G(^AMHREC(APCLBIEN,14)),U,2)
..I $D(APCLSPRV),X="" Q ;want only certain SCR providers on visit
..I $D(APCLSPRV),APCLSPRV'=X Q ;want one provider and it's not this one
..I APCLSPUN,X'="" Q ;want only unknown and this one has a SCR provider
..S ^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN)=""
Q
;
GETSCR ;
K ^XTMP("APCLDV3",APCLJ,APCLH,"VSTS")
S DFN=0 F S DFN=$O(^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN)) Q:DFN'=+DFN D GETSCR1
Q
GETSCR1 ;
;go through exam IPV, then through AUPNPREF for refusals
S APCLEIEN=0 F S APCLEIEN=$O(^AUPNVXAM("AC",DFN,APCLEIEN)) Q:APCLEIEN'=+APCLEIEN D
.Q:'$D(^AUPNVXAM(APCLEIEN,0))
.Q:$P(^AUPNVXAM(APCLEIEN,0),U)'=APCLEXC
.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 '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("APCLDV3",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("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,10)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
.S $P(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,15)=APCLVIEN
.S $P(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,16)=$$SPRV(APCLEIEN)
.S $P(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
.S ^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN,APCLDATE)=APCLCNT
;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
.S APCLRES=$$VAL^XBDIQ1(9000022,APCLRIEN,.07) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
.S APCLCNT=APCLCNT+1
.S ^XTMP("APCLDV3",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("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,16)=$$PRVREF(APCLRIEN)
.S $P(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
.S ^XTMP("APCLDV3",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("AF",DFN,APCLSD)) Q:APCLSD'=+APCLSD!($P(APCLSD,".")>APCLED) D
.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))
..Q:$P($G(^AMHREC(APCLBIEN,14)),U)=""
..Q:APCLDATE>APCLED
..Q:APCLDATE<APCLBD
..I $D(^XTMP("APCLDV3",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("APCLDV3",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("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,10)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
..S $P(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,15)=APCLBIEN
..S $P(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,16)=$$VAL^XBDIQ1(9002011,APCLBIEN,1402)
..S $P(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
Q
BHPPIN(R) ;
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)
Q %1
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,"N")
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")
;----------
APCLDV31 ; IHS/CMI/LAB - list IPV/DV screenings ;
+1 ;;2.0;IHS PCC SUITE;**8,10**;MAY 14, 2009;Build 88
+2 ;
+3 ;
PROC ;
+1 SET APCLCNT=0
+2 SET APCLH=$HOROLOG
SET APCLJ=$JOB
+3 KILL ^XTMP("APCLDV3",APCLJ,APCLH)
+4 DO XTMP^APCLOSUT("APCLDV3","IPV SCREENING REPORT")
+5 ;go through exam IPV, then through AUPNPREF for refusals
+6 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:1
+7 IF '$DATA(^DPT(DFN,0))
QUIT
+8 ;merged away
IF $PIECE(^DPT(DFN,0),U,19)
QUIT
+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 ;not right gender
IF APCLSEX'[$PIECE(^DPT(DFN,0),U,2)
QUIT
+13 ;not correct designated provider
IF APCLDESP]""
IF $PIECE(^AUPNPAT(DFN,0),U,14)'=APCLDESP
QUIT
+14 DO GATHER
+15 QUIT
End DoDot:1
+16 DO GETSCR
+17 QUIT
GATHER ;gather up all exams, refusals and bh in time period for patient in DFN
+1 ;if at least one match criteria then set ^xtmp($j,$h,"pts",dfn)=""
+2 SET APCLEIEN=0
FOR
SET APCLEIEN=$ORDER(^AUPNVXAM("AC",DFN,APCLEIEN))
IF APCLEIEN'=+APCLEIEN
QUIT
Begin DoDot:1
+3 IF '$DATA(^AUPNVXAM(APCLEIEN,0))
QUIT
+4 ;not ipv/dv
IF $PIECE(^AUPNVXAM(APCLEIEN,0),U)'=APCLEXC
QUIT
+5 SET APCLVIEN=$PIECE(^AUPNVXAM(APCLEIEN,0),U,3)
+6 IF 'APCLVIEN
QUIT
+7 SET APCLDATE=$PIECE($PIECE($GET(^AUPNVSIT(APCLVIEN,0)),U),".")
+8 IF APCLDATE=""
QUIT
+9 IF APCLDATE>APCLED
QUIT
+10 IF APCLDATE<APCLBD
QUIT
+11 IF APCLLOCT="O"
IF $PIECE(^AUPNVSIT(APCLVIEN,0),U,6)'=APCLLOCT("ONE")
QUIT
+12 IF APCLLOCT="S"
IF $$VALI^XBDIQ1(9999999.06,$PIECE(^AUPNVSIT(APCLVIEN,0),U,6),.05)'=APCLLOCT("SU")
QUIT
+13 SET X=$$AGE^AUPNPAT(DFN,APCLDATE)
+14 IF $DATA(APCLAGET)
IF X>$PIECE(APCLAGET,"-",2)
QUIT
+15 IF $DATA(APCLAGET)
IF X<$PIECE(APCLAGET,"-",1)
QUIT
+16 ;clinic check
+17 IF $DATA(APCLCLNT)
SET X=$PIECE(^AUPNVSIT(APCLVIEN,0),U,8)
IF X=""
QUIT
IF '$DATA(APCLCLNT(X))
QUIT
+18 ;bh exclude/include check
+19 IF 'APCLEXBH
SET C=$$CLINIC^APCLV(APCLVIEN,"C")
IF C=14!(C=43)!(C=48)!(C="C4")!(C="C9")
QUIT
+20 ;result check
+21 SET APCLRES=$$VAL^XBDIQ1(9000010.13,APCLEIEN,.04)
IF APCLRES["REFUSED"
SET APCLRES="REFUSED SCREENING"
IF APCLRES["NEGATIVE"
SET APCLRES="NEGATIVE"
+22 IF APCLRES="NEGATIVE"
IF '$DATA(APCLREST(1))
QUIT
+23 IF APCLRES="PRESENT"
IF '$DATA(APCLREST(2))
QUIT
+24 IF APCLRES="PAST"
IF '$DATA(APCLREST(3))
QUIT
+25 IF APCLRES=""
IF '$DATA(APCLREST(6))
QUIT
+26 ;PRIMARY PROVIDER CHECK
+27 SET X=$$PRIMPROV^APCLV(APCLVIEN,"I")
+28 ;want only certain primary providers on visit
IF $DATA(APCLPROV)
IF X=""
QUIT
+29 ;want one provider and it's not this one
IF $DATA(APCLPROV)
IF APCLPROV'=X
QUIT
+30 ;want only unknown and this one has a primary provider
IF APCLPPUN
IF X'=""
QUIT
+31 SET X=$PIECE($GET(^AUPNVXAM(APCLEIEN,12)),U,4)
+32 ;want only certain SCR providers on visit
IF $DATA(APCLSPRV)
IF X=""
QUIT
+33 ;want one provider and it's not this one
IF $DATA(APCLSPRV)
IF APCLSPRV'=X
QUIT
+34 ;want only unknown and this one has a SCR provider
IF APCLSPUN
IF X'=""
QUIT
+35 SET ^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN)=""
End DoDot:1
REF ;now go through refusals in pcc
+1 ;Q:$D(^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN)) ;already got one so no need to go on
+2 SET APCLRIEN=0
FOR
SET APCLRIEN=$ORDER(^AUPNPREF("AC",DFN,APCLRIEN))
IF APCLRIEN'=+APCLRIEN
QUIT
Begin DoDot:1
+3 IF '$DATA(^AUPNPREF(APCLRIEN,0))
QUIT
+4 IF $PIECE(^AUPNPREF(APCLRIEN,0),U,5)'=9999999.15
QUIT
+5 IF $PIECE(^AUPNPREF(APCLRIEN,0),U,6)'=APCLEXC
QUIT
+6 SET APCLDATE=$PIECE(^AUPNPREF(APCLRIEN,0),U,3)
+7 IF APCLDATE=""
QUIT
+8 IF APCLDATE>APCLED
QUIT
+9 IF APCLDATE<APCLBD
QUIT
+10 SET X=$$AGE^AUPNPAT(DFN,APCLDATE)
+11 IF $DATA(APCLAGET)
IF X>$PIECE(APCLAGET,"-",2)
QUIT
+12 IF $DATA(APCLAGET)
IF X<$PIECE(APCLAGET,"-",1)
QUIT
+13 SET APCLRES=$$VAL^XBDIQ1(9000022,APCLRIEN,.07)
IF APCLRES["REFUSED"
SET APCLRES="REFUSED SCREENING"
+14 ;do not want refusals
IF APCLRES["REFUSED"
IF '$DATA(APCLREST(4))
QUIT
+15 ;do not want unables
IF APCLRES["UNABLE"
IF '$DATA(APCLREST(5))
QUIT
+16 SET X=$PIECE($GET(^AUPNPREF(APCLRIEN,12)),U,4)
+17 ;want only certain SCR providers on visit
IF $DATA(APCLSPRV)
IF X=""
QUIT
+18 ;want one provider and it's not this one
IF $DATA(APCLSPRV)
IF APCLSPRV'=X
QUIT
+19 ;want only unknown and this one has a SCR provider
IF APCLSPUN
IF X'=""
QUIT
+20 SET ^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN)=""
End DoDot:1
+21 ;Q:$D(^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN)) ;already got this patient so no need to go on
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
Begin DoDot:1
+4 SET APCLBIEN=0
FOR
SET APCLBIEN=$ORDER(^AMHREC("AF",DFN,APCLSD,APCLBIEN))
IF APCLBIEN'=+APCLBIEN
QUIT
Begin DoDot:2
+5 SET APCLDATE=$PIECE(APCLSD,".")
+6 IF '$DATA(^AMHREC(APCLBIEN,0))
QUIT
+7 IF $PIECE($GET(^AMHREC(APCLBIEN,14)),U)=""
QUIT
+8 IF APCLDATE>APCLED
QUIT
+9 IF APCLDATE<APCLBD
QUIT
+10 IF APCLLOCT="O"
IF $PIECE(^AMHREC(APCLBIEN,0),U,4)'=APCLLOCT("ONE")
QUIT
+11 IF APCLLOCT="S"
IF $$VALI^XBDIQ1(9999999.06,$PIECE(^AMHREC(APCLBIEN,0),U,4),.05)'=APCLLOCT("SU")
QUIT
+12 SET X=$$AGE^AUPNPAT(DFN,APCLDATE)
+13 IF $DATA(APCLAGET)
IF X>$PIECE(APCLAGET,"-",2)
QUIT
+14 IF $DATA(APCLAGET)
IF X<$PIECE(APCLAGET,"-",1)
QUIT
+15 ;clinic check
+16 IF $DATA(APCLCLNT)
SET X=$PIECE(^AMHREC(APCLBIEN,0),U,25)
IF X=""
QUIT
IF '$DATA(APCLCLNT(X))
QUIT
+17 ;result check
+18 SET APCLRES=$$VAL^XBDIQ1(9002011,APCLBIEN,1401)
IF APCLRES["REFUSED"
SET APCLRES="REFUSED SCREENING"
IF APCLRES["NEGATIVE"
SET APCLRES="NEGATIVE"
+19 IF APCLRES="NEGATIVE"
IF '$DATA(APCLREST(1))
QUIT
+20 IF APCLRES="PRESENT"
IF '$DATA(APCLREST(2))
QUIT
+21 IF APCLRES="PAST"
IF '$DATA(APCLREST(3))
QUIT
+22 ;do not want refusals
IF APCLRES["REFUSED"
IF '$DATA(APCLREST(4))
QUIT
+23 ;do not want unables
IF APCLRES["UNABLE"
IF '$DATA(APCLREST(5))
QUIT
+24 IF APCLRES=""
IF '$DATA(APCLREST(6))
QUIT
+25 ;PRIMARY PROVIDER CHECK
+26 SET X=$$BHPPIN(APCLBIEN)
+27 ;want only certain primary providers on visit
IF $DATA(APCLPROV)
IF X=""
QUIT
+28 ;want one provider and it's not this one
IF $DATA(APCLPROV)
IF APCLPROV'=X
QUIT
+29 ;want only unknown and this one has a primary provider
IF APCLPPUN
IF X'=""
QUIT
+30 SET X=$PIECE($GET(^AMHREC(APCLBIEN,14)),U,2)
+31 ;want only certain SCR providers on visit
IF $DATA(APCLSPRV)
IF X=""
QUIT
+32 ;want one provider and it's not this one
IF $DATA(APCLSPRV)
IF APCLSPRV'=X
QUIT
+33 ;want only unknown and this one has a SCR provider
IF APCLSPUN
IF X'=""
QUIT
+34 SET ^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN)=""
End DoDot:2
End DoDot:1
+35 QUIT
+36 ;
GETSCR ;
+1 KILL ^XTMP("APCLDV3",APCLJ,APCLH,"VSTS")
+2 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN))
IF DFN'=+DFN
QUIT
DO GETSCR1
+3 QUIT
GETSCR1 ;
+1 ;go through exam IPV, then through AUPNPREF for refusals
+2 SET APCLEIEN=0
FOR
SET APCLEIEN=$ORDER(^AUPNVXAM("AC",DFN,APCLEIEN))
IF APCLEIEN'=+APCLEIEN
QUIT
Begin DoDot:1
+3 IF '$DATA(^AUPNVXAM(APCLEIEN,0))
QUIT
+4 IF $PIECE(^AUPNVXAM(APCLEIEN,0),U)'=APCLEXC
QUIT
+5 SET APCLVIEN=$PIECE(^AUPNVXAM(APCLEIEN,0),U,3)
+6 IF 'APCLVIEN
QUIT
+7 SET APCLDATE=$PIECE($PIECE($GET(^AUPNVSIT(APCLVIEN,0)),U),".")
+8 IF APCLDATE=""
QUIT
+9 IF APCLDATE>APCLED
QUIT
+10 IF APCLDATE<APCLBD
QUIT
+11 IF 'APCLEXBH
SET C=$$CLINIC^APCLV(APCLVIEN,"C")
IF C=14!(C=43)!(C=48)!(C="C4")!(C="C9")
QUIT
+12 SET APCLCNT=APCLCNT+1
+13 SET APCLRES=$$VAL^XBDIQ1(9000010.13,APCLEIEN,.04)
IF APCLRES["REFUSED"
SET APCLRES="REFUSED SCREENING"
IF APCLRES["NEGATIVE"
SET APCLRES="NEGATIVE"
+14 SET ^XTMP("APCLDV3",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
+15 SET $PIECE(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,10)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
+16 SET $PIECE(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,15)=APCLVIEN
+17 SET $PIECE(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,16)=$$SPRV(APCLEIEN)
+18 SET $PIECE(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
+19 SET ^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN,APCLDATE)=APCLCNT
End DoDot:1
+20 ;now go through refusals in pcc
+21 SET APCLRIEN=0
FOR
SET APCLRIEN=$ORDER(^AUPNPREF("AC",DFN,APCLRIEN))
IF APCLRIEN'=+APCLRIEN
QUIT
Begin DoDot:1
+22 IF '$DATA(^AUPNPREF(APCLRIEN,0))
QUIT
+23 IF $PIECE(^AUPNPREF(APCLRIEN,0),U,5)'=9999999.15
QUIT
+24 IF $PIECE(^AUPNPREF(APCLRIEN,0),U,6)'=APCLEXC
QUIT
+25 SET APCLDATE=$PIECE(^AUPNPREF(APCLRIEN,0),U,3)
+26 IF APCLDATE=""
QUIT
+27 IF APCLDATE>APCLED
QUIT
+28 IF APCLDATE<APCLBD
QUIT
+29 SET APCLRES=$$VAL^XBDIQ1(9000022,APCLRIEN,.07)
IF APCLRES["REFUSED"
SET APCLRES="REFUSED SCREENING"
IF APCLRES["NEGATIVE"
SET APCLRES="NEGATIVE"
+30 SET APCLCNT=APCLCNT+1
+31 SET ^XTMP("APCLDV3",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
+32 SET $PIECE(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,16)=$$PRVREF(APCLRIEN)
+33 SET $PIECE(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
+34 SET ^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN,APCLDATE)=APCLCNT
End DoDot:1
+35 ;now go through BH
+36 ;not if user doesn't want to
IF 'APCLEXBH
QUIT
+37 SET APCLSD=$$FMADD^XLFDT(APCLBD,-1)
SET APCLSD=APCLSD_".9999"
+38 FOR
SET APCLSD=$ORDER(^AMHREC("AF",DFN,APCLSD))
IF APCLSD'=+APCLSD!($PIECE(APCLSD,".")>APCLED)
QUIT
Begin DoDot:1
+39 SET APCLBIEN=0
FOR
SET APCLBIEN=$ORDER(^AMHREC("AF",DFN,APCLSD,APCLBIEN))
IF APCLBIEN'=+APCLBIEN
QUIT
Begin DoDot:2
+40 SET APCLDATE=$PIECE(APCLSD,".")
+41 IF '$DATA(^AMHREC(APCLBIEN,0))
QUIT
+42 IF $PIECE($GET(^AMHREC(APCLBIEN,14)),U)=""
QUIT
+43 IF APCLDATE>APCLED
QUIT
+44 IF APCLDATE<APCLBD
QUIT
+45 IF $DATA(^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN,APCLDATE))
QUIT
+46 SET APCLCNT=APCLCNT+1
+47 SET APCLRES=$$VAL^XBDIQ1(9002011,APCLBIEN,1401)
IF APCLRES["REFUSED"
SET APCLRES="REFUSED SCREENING"
IF APCLRES["NEGATIVE"
SET APCLRES="NEGATIVE"
+48 SET ^XTMP("APCLDV3",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
+49 SET $PIECE(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,10)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
+50 SET $PIECE(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,15)=APCLBIEN
+51 SET $PIECE(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,16)=$$VAL^XBDIQ1(9002011,APCLBIEN,1402)
+52 SET $PIECE(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
End DoDot:2
End DoDot:1
+53 QUIT
BHPPIN(R) ;
+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)
+3 QUIT %1
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,"N")
+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 ;----------
