AMHRSR31 ; IHS/CMI/LAB - list SUICIDE RISK ASSESSMENT screenings ;
;;4.0;IHS BEHAVIORAL HEALTH;**8**;JUN 02, 2010;Build 7
;
;
PROC ;
S AMHRCNT=0
S AMHRH=$H,AMHRJ=$J
K ^XTMP("AMHRSR3",AMHRJ,AMHRH)
D XTMP^AMHUTIL("AMHRSR3","SUICIDE RISK ASSESSMENT REPORT")
;go through exam SRA, 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:'$$ALLOWP^AMHUTIL(DUZ,DFN)
.Q:$$DEMO^AMHUTIL1(DFN,$G(AMHDEMO))
.I AMHRSEX'[$P(^DPT(DFN,0),U,2) Q ;not right gender
.I AMHRDESP]"",$P($G(^AMHPATR(DFN,0)),U,2)'=AMHRDESP Q ;not correct designated mh provider
.I AMHRSSP]"",$P($G(^AMHPATR(DFN,0)),U,3)'=AMHRSSP Q
.I AMHRCDP]"",$P($G(^AMHPATR(DFN,0)),U,4)'=AMHRCDP Q
.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)=""
BH ;now go through BH
S AMHRSD=$$FMADD^XLFDT(AMHRBD,-1),AMHRSD=AMHRSD_".9999"
F S AMHRSD=$O(^AMHREC("AF",DFN,AMHRSD)) Q:AMHRSD'=+AMHRSD!($P(AMHRSD,".")>AMHRED) D
.S AMHRBIEN=0 F S AMHRBIEN=$O(^AMHREC("AF",DFN,AMHRSD,AMHRBIEN)) Q:AMHRBIEN'=+AMHRBIEN D
..S AMHRDATE=$P(AMHRSD,".")
..Q:'$D(^AMHREC(AMHRBIEN,0))
..Q:$P($G(^AMHREC(AMHRBIEN,14)),U,7)=""
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHRBIEN)
..Q:AMHRDATE>AMHRED
..Q:AMHRDATE<AMHRBD
..S X=$$AGE^AUPNPAT(DFN,AMHRDATE)
..I $D(AMHRAGET),X>$P(AMHRAGET,"-",2) Q
..I $D(AMHRAGET),X<$P(AMHRAGET,"-",1) Q
..;clinic check
..I $D(AMHRCLNT) S X=$P(^AMHREC(AMHRBIEN,0),U,25) Q:X="" Q:'$D(AMHRCLNT(X))
..;result check
..S AMHRRES=$$VAL^XBDIQ1(9002011,AMHRBIEN,1407) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING"
..I AMHRRES="LOW",'$D(AMHRREST(1)) Q
..I AMHRRES="MODERATE",'$D(AMHRREST(2)) Q
..I AMHRRES="HIGH",'$D(AMHRREST(3)) Q
..I AMHRRES["REFUSED",'$D(AMHRREST(4)) Q ;do not want refusals
..I AMHRRES["UNABLE",'$D(AMHRREST(5)) Q ;do not want unables
..I AMHRRES["REFERRAL",'$D(AMHRREST(6)) Q ;do not want unables
..I AMHRRES="",'$D(AMHRREST(7)) Q
..;PRIMARY PROVIDER CHECK
..S X=$$BHPPIN(AMHRBIEN)
..I $D(AMHRPROV),X="" Q ;want only certain primary providers on visit
..I $D(AMHRPROV),'$D(AMHRPROV(X)) Q ;want one provider and it's not this one
..I AMHRPPUN,X'="" Q ;want only unknown and this one has a primary provider
..S X=$P($G(^AMHREC(AMHRBIEN,14)),U,8)
..I $D(AMHRSPRV),X="" Q ;want only certain SCR providers on visit
..I $D(AMHRSPRV),'$D(AMHRSPRV(X)) Q ;want one provider and it's not this one
..I AMHRSPUN,X'="" Q ;want only unknown and this one has a SCR provider
..S ^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN)=""
Q:$D(^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN)) ;already got this patient so no need to go on
PCC ;
Q:'AMHREXPC
S AMHREIEN=0 F S AMHREIEN=$O(^AUPNVXAM("AC",DFN,AMHREIEN)) Q:AMHREIEN'=+AMHREIEN D
.Q:'$D(^AUPNVXAM(AMHREIEN,0))
.Q:$P(^AUPNVXAM(AMHREIEN,0),U)'=AMHREXC ;not ipv/dv
.S AMHRVIEN=$P(^AUPNVXAM(AMHREIEN,0),U,3)
.Q:'AMHRVIEN
.Q:'$$ALLOWPCC^AMHUTIL(DUZ,AMHRVIEN)
.S AMHRDATE=$P($P($G(^AUPNVSIT(AMHRVIEN,0)),U),".")
.Q:AMHRDATE=""
.Q:AMHRDATE>AMHRED
.Q:AMHRDATE<AMHRBD
.S X=$$AGE^AUPNPAT(DFN,AMHRDATE)
.I $D(AMHRAGET),X>$P(AMHRAGET,"-",2) Q
.I $D(AMHRAGET),X<$P(AMHRAGET,"-",1) Q
.;clinic check
.I $D(AMHRCLNT) S X=$P(^AUPNVSIT(AMHRVIEN,0),U,8) Q:X="" Q:'$D(AMHRCLNT(X))
.;result check
.S AMHRRES=$$VAL^XBDIQ1(9000010.13,AMHREIEN,.04) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING"
.I AMHRRES="LOW",'$D(AMHRREST(1)) Q
.I AMHRRES="MODERATE",'$D(AMHRREST(2)) Q
.I AMHRRES="HIGH",'$D(AMHRREST(3)) Q
.I AMHRRES["REFERRAL",'$D(AMHRREST(6)) Q ;do not want unables
.I AMHRRES="",'$D(AMHRREST(7)) Q
.;PRIMARY PROVIDER CHECK
.S X=$$PRIMPROV^APCLV(AMHRVIEN,"I")
.I $D(AMHRPROV),X="" Q ;want only certain primary providers on visit
.I $D(AMHRPROV),'$D(AMHRPROV(X)) Q ;want one provider and it's not this one
.I AMHRPPUN,X'="" Q ;want only unknown and this one has a primary provider
.S X=$P($G(^AUPNVXAM(AMHREIEN,12)),U,4)
.I $D(AMHRSPRV),X="" Q ;want only certain SCR providers on visit
.I $D(AMHRSPRV),'$D(AMHRSPRV(X)) Q ;want one provider and it's not this one
.I AMHRSPUN,X'="" Q ;want only unknown and this one has a SCR provider
.S ^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN)=""
REF ;now go through refusals in pcc
Q:$D(^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN)) ;already got one so no need to go on
S AMHRRIEN=0 F S AMHRRIEN=$O(^AUPNPREF("AC",DFN,AMHRRIEN)) Q:AMHRRIEN'=+AMHRRIEN D
.Q:'$D(^AUPNPREF(AMHRRIEN,0))
.Q:$P(^AUPNPREF(AMHRRIEN,0),U,5)'=9999999.15
.Q:$P(^AUPNPREF(AMHRRIEN,0),U,6)'=AMHREXC
.S AMHRDATE=$P(^AUPNPREF(AMHRRIEN,0),U,3)
.Q:AMHRDATE=""
.Q:AMHRDATE>AMHRED
.Q:AMHRDATE<AMHRBD
.S X=$$AGE^AUPNPAT(DFN,AMHRDATE)
.I $D(AMHRAGET),X>$P(AMHRAGET,"-",2) Q
.I $D(AMHRAGET),X<$P(AMHRAGET,"-",1) Q
.S AMHRRES=$$VAL^XBDIQ1(9000022,AMHRRIEN,.07) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING"
.I AMHRRES["REFUSED",'$D(AMHRREST(4)) Q ;do not want refusals
.I AMHRRES["UNABLE",'$D(AMHRREST(5)) Q ;do not want unables
.S X=$P($G(^AUPNPREF(AMHRRIEN,12)),U,4)
.I $D(AMHRSPRV),X="" Q ;want only certain SCR providers on visit
.I $D(AMHRSPRV),'$D(AMHRSPRV(X)) Q ;want one provider and it's not this one
.I AMHRSPUN,X'="" Q ;want only unknown and this one has a SCR provider
.S ^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN)=""
Q
;
GETSCR ;
K ^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS")
S DFN=0 F S DFN=$O(^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN)) Q:DFN'=+DFN D GETSCR1
Q
GETSCR1 ;
S AMHRSD=$$FMADD^XLFDT(AMHRBD,-1),AMHRSD=AMHRSD_".9999"
F S AMHRSD=$O(^AMHREC("AF",DFN,AMHRSD)) Q:AMHRSD'=+AMHRSD!($P(AMHRSD,".")>AMHRED) D
.S AMHRBIEN=0 F S AMHRBIEN=$O(^AMHREC("AF",DFN,AMHRSD,AMHRBIEN)) Q:AMHRBIEN'=+AMHRBIEN D
..S AMHRDATE=$P(AMHRSD,".")
..Q:'$D(^AMHREC(AMHRBIEN,0))
..Q:$P($G(^AMHREC(AMHRBIEN,14)),U,7)=""
..Q:AMHRDATE>AMHRED
..Q:AMHRDATE<AMHRBD
..S AMHRCNT=AMHRCNT+1
..S AMHRRES=$$VAL^XBDIQ1(9002011,AMHRBIEN,1407) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING"
..I AMHRRES="LOW",'$D(AMHRREST(1)) Q
..I AMHRRES="MODERATE",'$D(AMHRREST(2)) Q
..I AMHRRES="HIGH",'$D(AMHRREST(3)) Q
..I AMHRRES["REFUSED",'$D(AMHRREST(4)) Q ;do not want refusals
..I AMHRRES["UNABLE",'$D(AMHRREST(5)) Q ;do not want unables
..I AMHRRES["REFERRAL",'$D(AMHRREST(6)) Q ;do not want unables
..I AMHRRES="",'$D(AMHRREST(7)) Q
..S ^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT)="BH"_U_$$BHPPNAME(AMHRBIEN)_U_AMHRRES_U_$$VAL^XBDIQ1(9002011,AMHRBIEN,1901)_U_$$AGE^AUPNPAT(DFN,AMHRDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_AMHRDATE_U_AMHRBIEN_U_DFN
..S $P(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,10)=$$VAL^XBDIQ1(9002011,AMHRBIEN,.25)
..S $P(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,15)=AMHRBIEN
..S $P(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,16)=$$VAL^XBDIQ1(9002011,AMHRBIEN,1408)
..S $P(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
Q:'AMHREXPC
;go through exam SRA, then through AUPNPREF for refusals
S AMHREIEN=0 F S AMHREIEN=$O(^AUPNVXAM("AC",DFN,AMHREIEN)) Q:AMHREIEN'=+AMHREIEN D
.Q:'$D(^AUPNVXAM(AMHREIEN,0))
.Q:$P(^AUPNVXAM(AMHREIEN,0),U)'=AMHREXC
.S AMHRVIEN=$P(^AUPNVXAM(AMHREIEN,0),U,3)
.Q:'AMHRVIEN
.S AMHRDATE=$P($P($G(^AUPNVSIT(AMHRVIEN,0)),U),".")
.Q:AMHRDATE=""
.Q:AMHRDATE>AMHRED
.Q:AMHRDATE<AMHRBD
.I $D(^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)) Q
.S AMHRCNT=AMHRCNT+1
.S AMHRRES=$$VAL^XBDIQ1(9000010.13,AMHREIEN,.04) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING"
.I AMHRRES="",'$D(AMHRREST(7)) Q ;NO BLANKS
.I AMHRRES="LOW",'$D(AMHRREST(1)) Q
.I AMHRRES="MODERATE",'$D(AMHRREST(2)) Q
.I AMHRRES="HIGH",'$D(AMHRREST(3)) Q
.I AMHRRES["REFERRAL",'$D(AMHRREST(6)) Q ;do not want unables
.I AMHRRES="",'$D(AMHRREST(7)) Q
.S ^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT)="EX"_U_$$PPV(AMHRVIEN)_U_AMHRRES_U_$$VAL^XBDIQ1(9000010.13,AMHREIEN,81101)_U_$$AGE^AUPNPAT(DFN,AMHRDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_AMHRDATE_U_AMHREIEN_U_DFN
.S $P(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,10)=$$VAL^XBDIQ1(9000010,AMHRVIEN,.08)
.S $P(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,15)=AMHRVIEN
.S $P(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,16)=$$SPRV(AMHREIEN)
.S $P(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
.S ^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)=AMHRCNT
;now go through refusals in pcc
S AMHRRIEN=0 F S AMHRRIEN=$O(^AUPNPREF("AC",DFN,AMHRRIEN)) Q:AMHRRIEN'=+AMHRRIEN D
.Q:'$D(^AUPNPREF(AMHRRIEN,0))
.Q:$P(^AUPNPREF(AMHRRIEN,0),U,5)'=9999999.15
.Q:$P(^AUPNPREF(AMHRRIEN,0),U,6)'=AMHREXC
.S AMHRDATE=$P(^AUPNPREF(AMHRRIEN,0),U,3)
.Q:AMHRDATE=""
.Q:AMHRDATE>AMHRED
.Q:AMHRDATE<AMHRBD
.I $P(^AUPNPREF(AMHRRIEN,0),U,7)="R",'$D(AMHRREST(4)) Q
.I $P(^AUPNPREF(AMHRRIEN,0),U,7)="U",'$D(AMHRREST(5)) Q
.I $D(^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)) Q
.S AMHRRES=$$VAL^XBDIQ1(9000022,AMHRRIEN,.07) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING"
.S AMHRCNT=AMHRCNT+1
.S ^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT)="REF"_U_"UNKNOWN"_U_AMHRRES_U_$$VAL^XBDIQ1(9000022,AMHRRIEN,1101)_U_$$AGE^AUPNPAT(DFN,AMHRDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_AMHRDATE_U_AMHRRIEN_U_DFN_U
.S $P(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,16)=$$PRVREF(AMHRRIEN)
.S $P(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
.S ^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)=AMHRCNT
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) ;
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,"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")
;----------
AMHRSR31 ; IHS/CMI/LAB - list SUICIDE RISK ASSESSMENT screenings ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**8**;JUN 02, 2010;Build 7
+2 ;
+3 ;
PROC ;
+1 SET AMHRCNT=0
+2 SET AMHRH=$HOROLOG
SET AMHRJ=$JOB
+3 KILL ^XTMP("AMHRSR3",AMHRJ,AMHRH)
+4 DO XTMP^AMHUTIL("AMHRSR3","SUICIDE RISK ASSESSMENT REPORT")
+5 ;go through exam SRA, 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 '$$ALLOWP^AMHUTIL(DUZ,DFN)
QUIT
+10 IF $$DEMO^AMHUTIL1(DFN,$GET(AMHDEMO))
QUIT
+11 ;not right gender
IF AMHRSEX'[$PIECE(^DPT(DFN,0),U,2)
QUIT
+12 ;not correct designated mh provider
IF AMHRDESP]""
IF $PIECE($GET(^AMHPATR(DFN,0)),U,2)'=AMHRDESP
QUIT
+13 IF AMHRSSP]""
IF $PIECE($GET(^AMHPATR(DFN,0)),U,3)'=AMHRSSP
QUIT
+14 IF AMHRCDP]""
IF $PIECE($GET(^AMHPATR(DFN,0)),U,4)'=AMHRCDP
QUIT
+15 DO GATHER
+16 QUIT
End DoDot:1
+17 DO GETSCR
+18 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)=""
BH ;now go through BH
+1 SET AMHRSD=$$FMADD^XLFDT(AMHRBD,-1)
SET AMHRSD=AMHRSD_".9999"
+2 FOR
SET AMHRSD=$ORDER(^AMHREC("AF",DFN,AMHRSD))
IF AMHRSD'=+AMHRSD!($PIECE(AMHRSD,".")>AMHRED)
QUIT
Begin DoDot:1
+3 SET AMHRBIEN=0
FOR
SET AMHRBIEN=$ORDER(^AMHREC("AF",DFN,AMHRSD,AMHRBIEN))
IF AMHRBIEN'=+AMHRBIEN
QUIT
Begin DoDot:2
+4 SET AMHRDATE=$PIECE(AMHRSD,".")
+5 IF '$DATA(^AMHREC(AMHRBIEN,0))
QUIT
+6 IF $PIECE($GET(^AMHREC(AMHRBIEN,14)),U,7)=""
QUIT
+7 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHRBIEN)
QUIT
+8 IF AMHRDATE>AMHRED
QUIT
+9 IF AMHRDATE<AMHRBD
QUIT
+10 SET X=$$AGE^AUPNPAT(DFN,AMHRDATE)
+11 IF $DATA(AMHRAGET)
IF X>$PIECE(AMHRAGET,"-",2)
QUIT
+12 IF $DATA(AMHRAGET)
IF X<$PIECE(AMHRAGET,"-",1)
QUIT
+13 ;clinic check
+14 IF $DATA(AMHRCLNT)
SET X=$PIECE(^AMHREC(AMHRBIEN,0),U,25)
IF X=""
QUIT
IF '$DATA(AMHRCLNT(X))
QUIT
+15 ;result check
+16 SET AMHRRES=$$VAL^XBDIQ1(9002011,AMHRBIEN,1407)
IF AMHRRES["REFUSED"
SET AMHRRES="REFUSED SCREENING"
+17 IF AMHRRES="LOW"
IF '$DATA(AMHRREST(1))
QUIT
+18 IF AMHRRES="MODERATE"
IF '$DATA(AMHRREST(2))
QUIT
+19 IF AMHRRES="HIGH"
IF '$DATA(AMHRREST(3))
QUIT
+20 ;do not want refusals
IF AMHRRES["REFUSED"
IF '$DATA(AMHRREST(4))
QUIT
+21 ;do not want unables
IF AMHRRES["UNABLE"
IF '$DATA(AMHRREST(5))
QUIT
+22 ;do not want unables
IF AMHRRES["REFERRAL"
IF '$DATA(AMHRREST(6))
QUIT
+23 IF AMHRRES=""
IF '$DATA(AMHRREST(7))
QUIT
+24 ;PRIMARY PROVIDER CHECK
+25 SET X=$$BHPPIN(AMHRBIEN)
+26 ;want only certain primary providers on visit
IF $DATA(AMHRPROV)
IF X=""
QUIT
+27 ;want one provider and it's not this one
IF $DATA(AMHRPROV)
IF '$DATA(AMHRPROV(X))
QUIT
+28 ;want only unknown and this one has a primary provider
IF AMHRPPUN
IF X'=""
QUIT
+29 SET X=$PIECE($GET(^AMHREC(AMHRBIEN,14)),U,8)
+30 ;want only certain SCR providers on visit
IF $DATA(AMHRSPRV)
IF X=""
QUIT
+31 ;want one provider and it's not this one
IF $DATA(AMHRSPRV)
IF '$DATA(AMHRSPRV(X))
QUIT
+32 ;want only unknown and this one has a SCR provider
IF AMHRSPUN
IF X'=""
QUIT
+33 SET ^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN)=""
End DoDot:2
End DoDot:1
+34 ;already got this patient so no need to go on
IF $DATA(^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN))
QUIT
PCC ;
+1 IF 'AMHREXPC
QUIT
+2 SET AMHREIEN=0
FOR
SET AMHREIEN=$ORDER(^AUPNVXAM("AC",DFN,AMHREIEN))
IF AMHREIEN'=+AMHREIEN
QUIT
Begin DoDot:1
+3 IF '$DATA(^AUPNVXAM(AMHREIEN,0))
QUIT
+4 ;not ipv/dv
IF $PIECE(^AUPNVXAM(AMHREIEN,0),U)'=AMHREXC
QUIT
+5 SET AMHRVIEN=$PIECE(^AUPNVXAM(AMHREIEN,0),U,3)
+6 IF 'AMHRVIEN
QUIT
+7 IF '$$ALLOWPCC^AMHUTIL(DUZ,AMHRVIEN)
QUIT
+8 SET AMHRDATE=$PIECE($PIECE($GET(^AUPNVSIT(AMHRVIEN,0)),U),".")
+9 IF AMHRDATE=""
QUIT
+10 IF AMHRDATE>AMHRED
QUIT
+11 IF AMHRDATE<AMHRBD
QUIT
+12 SET X=$$AGE^AUPNPAT(DFN,AMHRDATE)
+13 IF $DATA(AMHRAGET)
IF X>$PIECE(AMHRAGET,"-",2)
QUIT
+14 IF $DATA(AMHRAGET)
IF X<$PIECE(AMHRAGET,"-",1)
QUIT
+15 ;clinic check
+16 IF $DATA(AMHRCLNT)
SET X=$PIECE(^AUPNVSIT(AMHRVIEN,0),U,8)
IF X=""
QUIT
IF '$DATA(AMHRCLNT(X))
QUIT
+17 ;result check
+18 SET AMHRRES=$$VAL^XBDIQ1(9000010.13,AMHREIEN,.04)
IF AMHRRES["REFUSED"
SET AMHRRES="REFUSED SCREENING"
+19 IF AMHRRES="LOW"
IF '$DATA(AMHRREST(1))
QUIT
+20 IF AMHRRES="MODERATE"
IF '$DATA(AMHRREST(2))
QUIT
+21 IF AMHRRES="HIGH"
IF '$DATA(AMHRREST(3))
QUIT
+22 ;do not want unables
IF AMHRRES["REFERRAL"
IF '$DATA(AMHRREST(6))
QUIT
+23 IF AMHRRES=""
IF '$DATA(AMHRREST(7))
QUIT
+24 ;PRIMARY PROVIDER CHECK
+25 SET X=$$PRIMPROV^APCLV(AMHRVIEN,"I")
+26 ;want only certain primary providers on visit
IF $DATA(AMHRPROV)
IF X=""
QUIT
+27 ;want one provider and it's not this one
IF $DATA(AMHRPROV)
IF '$DATA(AMHRPROV(X))
QUIT
+28 ;want only unknown and this one has a primary provider
IF AMHRPPUN
IF X'=""
QUIT
+29 SET X=$PIECE($GET(^AUPNVXAM(AMHREIEN,12)),U,4)
+30 ;want only certain SCR providers on visit
IF $DATA(AMHRSPRV)
IF X=""
QUIT
+31 ;want one provider and it's not this one
IF $DATA(AMHRSPRV)
IF '$DATA(AMHRSPRV(X))
QUIT
+32 ;want only unknown and this one has a SCR provider
IF AMHRSPUN
IF X'=""
QUIT
+33 SET ^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN)=""
End DoDot:1
REF ;now go through refusals in pcc
+1 ;already got one so no need to go on
IF $DATA(^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN))
QUIT
+2 SET AMHRRIEN=0
FOR
SET AMHRRIEN=$ORDER(^AUPNPREF("AC",DFN,AMHRRIEN))
IF AMHRRIEN'=+AMHRRIEN
QUIT
Begin DoDot:1
+3 IF '$DATA(^AUPNPREF(AMHRRIEN,0))
QUIT
+4 IF $PIECE(^AUPNPREF(AMHRRIEN,0),U,5)'=9999999.15
QUIT
+5 IF $PIECE(^AUPNPREF(AMHRRIEN,0),U,6)'=AMHREXC
QUIT
+6 SET AMHRDATE=$PIECE(^AUPNPREF(AMHRRIEN,0),U,3)
+7 IF AMHRDATE=""
QUIT
+8 IF AMHRDATE>AMHRED
QUIT
+9 IF AMHRDATE<AMHRBD
QUIT
+10 SET X=$$AGE^AUPNPAT(DFN,AMHRDATE)
+11 IF $DATA(AMHRAGET)
IF X>$PIECE(AMHRAGET,"-",2)
QUIT
+12 IF $DATA(AMHRAGET)
IF X<$PIECE(AMHRAGET,"-",1)
QUIT
+13 SET AMHRRES=$$VAL^XBDIQ1(9000022,AMHRRIEN,.07)
IF AMHRRES["REFUSED"
SET AMHRRES="REFUSED SCREENING"
+14 ;do not want refusals
IF AMHRRES["REFUSED"
IF '$DATA(AMHRREST(4))
QUIT
+15 ;do not want unables
IF AMHRRES["UNABLE"
IF '$DATA(AMHRREST(5))
QUIT
+16 SET X=$PIECE($GET(^AUPNPREF(AMHRRIEN,12)),U,4)
+17 ;want only certain SCR providers on visit
IF $DATA(AMHRSPRV)
IF X=""
QUIT
+18 ;want one provider and it's not this one
IF $DATA(AMHRSPRV)
IF '$DATA(AMHRSPRV(X))
QUIT
+19 ;want only unknown and this one has a SCR provider
IF AMHRSPUN
IF X'=""
QUIT
+20 SET ^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN)=""
End DoDot:1
+21 QUIT
+22 ;
GETSCR ;
+1 KILL ^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS")
+2 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN))
IF DFN'=+DFN
QUIT
DO GETSCR1
+3 QUIT
GETSCR1 ;
+1 SET AMHRSD=$$FMADD^XLFDT(AMHRBD,-1)
SET AMHRSD=AMHRSD_".9999"
+2 FOR
SET AMHRSD=$ORDER(^AMHREC("AF",DFN,AMHRSD))
IF AMHRSD'=+AMHRSD!($PIECE(AMHRSD,".")>AMHRED)
QUIT
Begin DoDot:1
+3 SET AMHRBIEN=0
FOR
SET AMHRBIEN=$ORDER(^AMHREC("AF",DFN,AMHRSD,AMHRBIEN))
IF AMHRBIEN'=+AMHRBIEN
QUIT
Begin DoDot:2
+4 SET AMHRDATE=$PIECE(AMHRSD,".")
+5 IF '$DATA(^AMHREC(AMHRBIEN,0))
QUIT
+6 IF $PIECE($GET(^AMHREC(AMHRBIEN,14)),U,7)=""
QUIT
+7 IF AMHRDATE>AMHRED
QUIT
+8 IF AMHRDATE<AMHRBD
QUIT
+9 SET AMHRCNT=AMHRCNT+1
+10 SET AMHRRES=$$VAL^XBDIQ1(9002011,AMHRBIEN,1407)
IF AMHRRES["REFUSED"
SET AMHRRES="REFUSED SCREENING"
+11 IF AMHRRES="LOW"
IF '$DATA(AMHRREST(1))
QUIT
+12 IF AMHRRES="MODERATE"
IF '$DATA(AMHRREST(2))
QUIT
+13 IF AMHRRES="HIGH"
IF '$DATA(AMHRREST(3))
QUIT
+14 ;do not want refusals
IF AMHRRES["REFUSED"
IF '$DATA(AMHRREST(4))
QUIT
+15 ;do not want unables
IF AMHRRES["UNABLE"
IF '$DATA(AMHRREST(5))
QUIT
+16 ;do not want unables
IF AMHRRES["REFERRAL"
IF '$DATA(AMHRREST(6))
QUIT
+17 IF AMHRRES=""
IF '$DATA(AMHRREST(7))
QUIT
+18 SET ^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT)="BH"_U_$$BHPPNAME(AMHRBIEN)_U_AMHRRES_U_$$VAL^XBDIQ1(9002011,AMHRBIEN,1901)_U_$$AGE^AUPNPAT(DFN,AMHRDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_AMHRDATE_U_AMHRBIEN_U_DFN
+19 SET $PIECE(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,10)=$$VAL^XBDIQ1(9002011,AMHRBIEN,.25)
+20 SET $PIECE(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,15)=AMHRBIEN
+21 SET $PIECE(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,16)=$$VAL^XBDIQ1(9002011,AMHRBIEN,1408)
+22 SET $PIECE(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
End DoDot:2
End DoDot:1
+23 IF 'AMHREXPC
QUIT
+24 ;go through exam SRA, then through AUPNPREF for refusals
+25 SET AMHREIEN=0
FOR
SET AMHREIEN=$ORDER(^AUPNVXAM("AC",DFN,AMHREIEN))
IF AMHREIEN'=+AMHREIEN
QUIT
Begin DoDot:1
+26 IF '$DATA(^AUPNVXAM(AMHREIEN,0))
QUIT
+27 IF $PIECE(^AUPNVXAM(AMHREIEN,0),U)'=AMHREXC
QUIT
+28 SET AMHRVIEN=$PIECE(^AUPNVXAM(AMHREIEN,0),U,3)
+29 IF 'AMHRVIEN
QUIT
+30 SET AMHRDATE=$PIECE($PIECE($GET(^AUPNVSIT(AMHRVIEN,0)),U),".")
+31 IF AMHRDATE=""
QUIT
+32 IF AMHRDATE>AMHRED
QUIT
+33 IF AMHRDATE<AMHRBD
QUIT
+34 IF $DATA(^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE))
QUIT
+35 SET AMHRCNT=AMHRCNT+1
+36 SET AMHRRES=$$VAL^XBDIQ1(9000010.13,AMHREIEN,.04)
IF AMHRRES["REFUSED"
SET AMHRRES="REFUSED SCREENING"
+37 ;NO BLANKS
IF AMHRRES=""
IF '$DATA(AMHRREST(7))
QUIT
+38 IF AMHRRES="LOW"
IF '$DATA(AMHRREST(1))
QUIT
+39 IF AMHRRES="MODERATE"
IF '$DATA(AMHRREST(2))
QUIT
+40 IF AMHRRES="HIGH"
IF '$DATA(AMHRREST(3))
QUIT
+41 ;do not want unables
IF AMHRRES["REFERRAL"
IF '$DATA(AMHRREST(6))
QUIT
+42 IF AMHRRES=""
IF '$DATA(AMHRREST(7))
QUIT
+43 SET ^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT)="EX"_U_$$PPV(AMHRVIEN)_U_AMHRRES_U_$$VAL^XBDIQ1(9000010.13,AMHREIEN,81101)_U_$$AGE^AUPNPAT(DFN,AMHRDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_AMHRDATE_U_AMHREIEN_U_DFN
+44 SET $PIECE(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,10)=$$VAL^XBDIQ1(9000010,AMHRVIEN,.08)
+45 SET $PIECE(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,15)=AMHRVIEN
+46 SET $PIECE(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,16)=$$SPRV(AMHREIEN)
+47 SET $PIECE(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
+48 SET ^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)=AMHRCNT
End DoDot:1
+49 ;now go through refusals in pcc
+50 SET AMHRRIEN=0
FOR
SET AMHRRIEN=$ORDER(^AUPNPREF("AC",DFN,AMHRRIEN))
IF AMHRRIEN'=+AMHRRIEN
QUIT
Begin DoDot:1
+51 IF '$DATA(^AUPNPREF(AMHRRIEN,0))
QUIT
+52 IF $PIECE(^AUPNPREF(AMHRRIEN,0),U,5)'=9999999.15
QUIT
+53 IF $PIECE(^AUPNPREF(AMHRRIEN,0),U,6)'=AMHREXC
QUIT
+54 SET AMHRDATE=$PIECE(^AUPNPREF(AMHRRIEN,0),U,3)
+55 IF AMHRDATE=""
QUIT
+56 IF AMHRDATE>AMHRED
QUIT
+57 IF AMHRDATE<AMHRBD
QUIT
+58 IF $PIECE(^AUPNPREF(AMHRRIEN,0),U,7)="R"
IF '$DATA(AMHRREST(4))
QUIT
+59 IF $PIECE(^AUPNPREF(AMHRRIEN,0),U,7)="U"
IF '$DATA(AMHRREST(5))
QUIT
+60 IF $DATA(^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE))
QUIT
+61 SET AMHRRES=$$VAL^XBDIQ1(9000022,AMHRRIEN,.07)
IF AMHRRES["REFUSED"
SET AMHRRES="REFUSED SCREENING"
+62 SET AMHRCNT=AMHRCNT+1
+63 SET ^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT)="REF"_U_"UNKNOWN"_U_AMHRRES_U_$$VAL^XBDIQ1(9000022,AMHRRIEN,1101)_U_$$AGE^AUPNPAT(DFN,AMHRDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_AMHRDATE_U_AMHRRIEN_U_DFN_U
+64 SET $PIECE(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,16)=$$PRVREF(AMHRRIEN)
+65 SET $PIECE(^XTMP("AMHRSR3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
+66 SET ^XTMP("AMHRSR3",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)=AMHRCNT
End DoDot:1
+67 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 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,"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 ;----------
