Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AMHRDV31

AMHRDV31.m

Go to the documentation of this file. 
  1. AMHRDV31 ; IHS/CMI/LAB - list IPV/DV screenings ;
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;**6,8**;JUN 02, 2010;Build 7
  1.  ;
  1.  ;
  1. PROC ;
  1.  S AMHRCNT=0
  1.  S AMHRH=$H,AMHRJ=$J
  1.  K ^XTMP("AMHRDV3",AMHRJ,AMHRH)
  1.  D XTMP^AMHUTIL("AMHRDV3","IPV SCREENING REPORT")
  1.  ;go through exam IPV, then through AUPNPREF for refusals
  1.  S DFN=0 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  D
  1.  .Q:'$D(^DPT(DFN,0))
  1.  .Q:$P(^DPT(DFN,0),U,19)  ;merged away
  1.  .Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)
  1.  .Q:$$DEMO^AMHUTIL1(DFN,$G(AMHDEMO))
  1.  .I AMHRSEX'[$P(^DPT(DFN,0),U,2) Q  ;not right gender
  1.  .I AMHRDESP]"",$P($G(^AMHPATR(DFN,0)),U,2)'=AMHRDESP Q  ;not correct designated mh provider
  1.  .I AMHRSSP]"",$P($G(^AMHPATR(DFN,0)),U,3)'=AMHRSSP Q
  1.  .I AMHRCDP]"",$P($G(^AMHPATR(DFN,0)),U,4)'=AMHRCDP Q
  1.  .D GATHER
  1.  .Q
  1.  D GETSCR
  1.  Q
  1. 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)=""
  1. BH ;now go through BH
  1.  S AMHRSD=$$FMADD^XLFDT(AMHRBD,-1),AMHRSD=AMHRSD_".9999"
  1.  F  S AMHRSD=$O(^AMHREC("AF",DFN,AMHRSD)) Q:AMHRSD'=+AMHRSD!($P(AMHRSD,".")>AMHRED)  D
  1.  .S AMHRBIEN=0 F  S AMHRBIEN=$O(^AMHREC("AF",DFN,AMHRSD,AMHRBIEN)) Q:AMHRBIEN'=+AMHRBIEN  D
  1.  ..S AMHRDATE=$P(AMHRSD,".")
  1.  ..Q:'$D(^AMHREC(AMHRBIEN,0))
  1.  ..Q:$P($G(^AMHREC(AMHRBIEN,14)),U)=""
  1.  ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHRBIEN)
  1.  ..Q:AMHRDATE>AMHRED
  1.  ..Q:AMHRDATE<AMHRBD
  1.  ..S X=$$AGE^AUPNPAT(DFN,AMHRDATE)
  1.  ..I $D(AMHRAGET),X>$P(AMHRAGET,"-",2) Q
  1.  ..I $D(AMHRAGET),X<$P(AMHRAGET,"-",1) Q
  1.  ..;clinic check
  1.  ..I $D(AMHRCLNT) S X=$P(^AMHREC(AMHRBIEN,0),U,25) Q:X=""  Q:'$D(AMHRCLNT(X))
  1.  ..;result check
  1.  ..S AMHRRES=$$VAL^XBDIQ1(9002011,AMHRBIEN,1401) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING" S:AMHRRES["NEGATIVE" AMHRRES="NEGATIVE"
  1.  ..I AMHRRES="NEGATIVE",'$D(AMHRREST(1)) Q
  1.  ..I AMHRRES="PRESENT",'$D(AMHRREST(2)) Q
  1.  ..I AMHRRES="PAST",'$D(AMHRREST(3)) Q
  1.  ..I AMHRRES="PRESENT AND PAST",'$D(AMHRREST(4)) Q
  1.  ..I AMHRRES["REFUSED",'$D(AMHRREST(5)) Q  ;do not want refusals
  1.  ..I AMHRRES["UNABLE",'$D(AMHRREST(6)) Q  ;do not want unables
  1.  ..I AMHRRES["REFERRAL",'$D(AMHRREST(7)) Q  ;do not want unables
  1.  ..I AMHRRES="",'$D(AMHRREST(8)) Q
  1.  ..;PRIMARY PROVIDER CHECK
  1.  ..S X=$$BHPPIN(AMHRBIEN)
  1.  ..I $D(AMHRPROV),X="" Q  ;want only certain primary providers on visit
  1.  ..I $D(AMHRPROV),'$D(AMHRPROV(X)) Q  ;want one provider and it's not this one
  1.  ..I AMHRPPUN,X'="" Q  ;want only unknown and this one has a primary provider
  1.  ..S X=$P($G(^AMHREC(AMHRBIEN,14)),U,2)
  1.  ..I $D(AMHRSPRV),X="" Q  ;want only certain SCR providers on visit
  1.  ..I $D(AMHRSPRV),'$D(AMHRSPRV(X)) Q  ;want one provider and it's not this one
  1.  ..I AMHRSPUN,X'="" Q  ;want only unknown and this one has a SCR provider
  1.  ..S ^XTMP("AMHRDV3",AMHRJ,AMHRH,"PTS",DFN)=""
  1.  Q:$D(^XTMP("AMHRDV3",AMHRJ,AMHRH,"PTS",DFN))   ;already got this patient so no need to go on
  1. PCC ;
  1.  Q:'AMHREXPC
  1.  S AMHREIEN=0 F  S AMHREIEN=$O(^AUPNVXAM("AC",DFN,AMHREIEN)) Q:AMHREIEN'=+AMHREIEN  D
  1.  .Q:'$D(^AUPNVXAM(AMHREIEN,0))
  1.  .Q:$P(^AUPNVXAM(AMHREIEN,0),U)'=AMHREXC  ;not ipv/dv
  1.  .S AMHRVIEN=$P(^AUPNVXAM(AMHREIEN,0),U,3)
  1.  .Q:'AMHRVIEN
  1.  .Q:'$$ALLOWPCC^AMHUTIL(DUZ,AMHRVIEN)
  1.  .S AMHRDATE=$P($P($G(^AUPNVSIT(AMHRVIEN,0)),U),".")
  1.  .Q:AMHRDATE=""
  1.  .Q:AMHRDATE>AMHRED
  1.  .Q:AMHRDATE<AMHRBD
  1.  .S X=$$AGE^AUPNPAT(DFN,AMHRDATE)
  1.  .I $D(AMHRAGET),X>$P(AMHRAGET,"-",2) Q
  1.  .I $D(AMHRAGET),X<$P(AMHRAGET,"-",1) Q
  1.  .;clinic check
  1.  .I $D(AMHRCLNT) S X=$P(^AUPNVSIT(AMHRVIEN,0),U,8) Q:X=""  Q:'$D(AMHRCLNT(X))
  1.  .;result check
  1.  .S AMHRRES=$$VAL^XBDIQ1(9000010.13,AMHREIEN,.04) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING" S:AMHRRES["NEGATIVE" AMHRRES="NEGATIVE"
  1.  .I AMHRRES="NEGATIVE",'$D(AMHRREST(1)) Q
  1.  .I AMHRRES="PRESENT",'$D(AMHRREST(2)) Q
  1.  .I AMHRRES="PAST",'$D(AMHRREST(3)) Q
  1.  .I AMHRRES="PRESENT AND PAST",'$D(AMHRREST(4)) Q
  1.  .I AMHRRES["REFERRAL",'$D(AMHRREST(7)) Q  ;do not want unables
  1.  .I AMHRRES="",'$D(AMHRREST(8)) Q
  1.  .;PRIMARY PROVIDER CHECK
  1.  .S X=$$PRIMPROV^APCLV(AMHRVIEN,"I")
  1.  .I $D(AMHRPROV),X="" Q  ;want only certain primary providers on visit
  1.  .I $D(AMHRPROV),'$D(AMHRPROV(X)) Q  ;want one provider and it's not this one
  1.  .I AMHRPPUN,X'="" Q  ;want only unknown and this one has a primary provider
  1.  .S X=$P($G(^AUPNVXAM(AMHREIEN,12)),U,4)
  1.  .I $D(AMHRSPRV),X="" Q  ;want only certain SCR providers on visit
  1.  .I $D(AMHRSPRV),'$D(AMHRSPRV(X)) Q  ;want one provider and it's not this one
  1.  .I AMHRSPUN,X'="" Q  ;want only unknown and this one has a SCR provider
  1.  .S ^XTMP("AMHRDV3",AMHRJ,AMHRH,"PTS",DFN)=""
  1. REF ;now go through refusals in pcc
  1.  Q:$D(^XTMP("AMHRDV3",AMHRJ,AMHRH,"PTS",DFN))  ;already got one so no need to go on
  1.  S AMHRRIEN=0 F  S AMHRRIEN=$O(^AUPNPREF("AC",DFN,AMHRRIEN)) Q:AMHRRIEN'=+AMHRRIEN  D
  1.  .Q:'$D(^AUPNPREF(AMHRRIEN,0))
  1.  .Q:$P(^AUPNPREF(AMHRRIEN,0),U,5)'=9999999.15
  1.  .Q:$P(^AUPNPREF(AMHRRIEN,0),U,6)'=AMHREXC
  1.  .S AMHRDATE=$P(^AUPNPREF(AMHRRIEN,0),U,3)
  1.  .Q:AMHRDATE=""
  1.  .Q:AMHRDATE>AMHRED
  1.  .Q:AMHRDATE<AMHRBD
  1.  .S X=$$AGE^AUPNPAT(DFN,AMHRDATE)
  1.  .I $D(AMHRAGET),X>$P(AMHRAGET,"-",2) Q
  1.  .I $D(AMHRAGET),X<$P(AMHRAGET,"-",1) Q
  1.  .S AMHRRES=$$VAL^XBDIQ1(9000022,AMHRRIEN,.07) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING"
  1.  .I AMHRRES["REFUSED",'$D(AMHRREST(5)) Q  ;do not want refusals
  1.  .I AMHRRES["UNABLE",'$D(AMHRREST(6)) Q  ;do not want unables
  1.  .S X=$P($G(^AUPNPREF(AMHRRIEN,12)),U,4)
  1.  .I $D(AMHRSPRV),X="" Q  ;want only certain SCR providers on visit
  1.  .I $D(AMHRSPRV),'$D(AMHRSPRV(X)) Q  ;want one provider and it's not this one
  1.  .I AMHRSPUN,X'="" Q  ;want only unknown and this one has a SCR provider
  1.  .S ^XTMP("AMHRDV3",AMHRJ,AMHRH,"PTS",DFN)=""
  1.  Q
  1.  ;
  1. GETSCR ;
  1.  K ^XTMP("AMHRDV3",AMHRJ,AMHRH,"VSTS")
  1.  S DFN=0 F  S DFN=$O(^XTMP("AMHRDV3",AMHRJ,AMHRH,"PTS",DFN)) Q:DFN'=+DFN  D GETSCR1
  1.  Q
  1. GETSCR1 ;
  1.  S AMHRSD=$$FMADD^XLFDT(AMHRBD,-1),AMHRSD=AMHRSD_".9999"
  1.  F  S AMHRSD=$O(^AMHREC("AF",DFN,AMHRSD)) Q:AMHRSD'=+AMHRSD!($P(AMHRSD,".")>AMHRED)  D
  1.  .S AMHRBIEN=0 F  S AMHRBIEN=$O(^AMHREC("AF",DFN,AMHRSD,AMHRBIEN)) Q:AMHRBIEN'=+AMHRBIEN  D
  1.  ..S AMHRDATE=$P(AMHRSD,".")
  1.  ..Q:'$D(^AMHREC(AMHRBIEN,0))
  1.  ..Q:$P($G(^AMHREC(AMHRBIEN,14)),U)=""
  1.  ..Q:AMHRDATE>AMHRED
  1.  ..Q:AMHRDATE<AMHRBD
  1.  ..S AMHRCNT=AMHRCNT+1
  1.  ..S AMHRRES=$$VAL^XBDIQ1(9002011,AMHRBIEN,1401) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING" S:AMHRRES["NEGATIVE" AMHRRES="NEGATIVE"
  1.  ..I AMHRRES="NEGATIVE",'$D(AMHRREST(1)) Q
  1.  ..I AMHRRES="PRESENT",'$D(AMHRREST(2)) Q
  1.  ..I AMHRRES="PAST",'$D(AMHRREST(3)) Q
  1.  ..I AMHRRES="PRESENT AND PAST",'$D(AMHRREST(4)) Q
  1.  ..I AMHRRES["REFUSED",'$D(AMHRREST(5)) Q  ;do not want refusals
  1.  ..I AMHRRES["UNABLE",'$D(AMHRREST(6)) Q  ;do not want unables
  1.  ..I AMHRRES["REFERRAL",'$D(AMHRREST(7)) Q  ;no referrals
  1.  ..I AMHRRES="",'$D(AMHRREST(8)) Q
  1.  ..S ^XTMP("AMHRDV3",AMHRJ,AMHRH,"VSTS",AMHRCNT)="BH"_U_$$BHPPNAME(AMHRBIEN)_U_AMHRRES_U_$$VAL^XBDIQ1(9002011,AMHRBIEN,1501)_U_$$AGE^AUPNPAT(DFN,AMHRDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_AMHRDATE_U_AMHRBIEN_U_DFN
  1.  ..S $P(^XTMP("AMHRDV3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,10)=$$VAL^XBDIQ1(9002011,AMHRBIEN,.25)
  1.  ..S $P(^XTMP("AMHRDV3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,15)=AMHRBIEN
  1.  ..S $P(^XTMP("AMHRDV3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,16)=$$VAL^XBDIQ1(9002011,AMHRBIEN,1402)
  1.  ..S $P(^XTMP("AMHRDV3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
  1.  Q:'AMHREXPC
  1.  ;go through exam IPV, then through AUPNPREF for refusals
  1.  S AMHREIEN=0 F  S AMHREIEN=$O(^AUPNVXAM("AC",DFN,AMHREIEN)) Q:AMHREIEN'=+AMHREIEN  D
  1.  .Q:'$D(^AUPNVXAM(AMHREIEN,0))
  1.  .Q:$P(^AUPNVXAM(AMHREIEN,0),U)'=AMHREXC
  1.  .S AMHRVIEN=$P(^AUPNVXAM(AMHREIEN,0),U,3)
  1.  .Q:'AMHRVIEN
  1.  .S AMHRDATE=$P($P($G(^AUPNVSIT(AMHRVIEN,0)),U),".")
  1.  .Q:AMHRDATE=""
  1.  .Q:AMHRDATE>AMHRED
  1.  .Q:AMHRDATE<AMHRBD
  1.  .I $D(^XTMP("AMHRDV3",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)) Q
  1.  .S AMHRCNT=AMHRCNT+1
  1.  .S AMHRRES=$$VAL^XBDIQ1(9000010.13,AMHREIEN,.04) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING" S:AMHRRES["NEGATIVE" AMHRRES="NEGATIVE"
  1.  .I AMHRRES="",'$D(AMHRREST(8)) Q  ;NO BLANKS
  1.  .I AMHRRES="NEGATIVE",'$D(AMHRREST(1)) Q
  1.  .I AMHRRES="PRESENT",'$D(AMHRREST(2)) Q
  1.  .I AMHRRES="PAST",'$D(AMHRREST(3)) Q
  1.  .I AMHRRES="PRESENT AND PAST",'$D(AMHRREST(4)) Q
  1.  .I AMHRRES["UNABLE",'$D(AMHRREST(6)) Q  ;do not want unables
  1.  .I AMHRRES["REFERRAL",'$D(AMHRREST(7)) Q  ;no referrals
  1.  .S ^XTMP("AMHRDV3",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
  1.  .S $P(^XTMP("AMHRDV3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,10)=$$VAL^XBDIQ1(9000010,AMHRVIEN,.08)
  1.  .S $P(^XTMP("AMHRDV3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,15)=AMHRVIEN
  1.  .S $P(^XTMP("AMHRDV3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,16)=$$SPRV(AMHREIEN)
  1.  .S $P(^XTMP("AMHRDV3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
  1.  .S ^XTMP("AMHRDV3",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)=AMHRCNT
  1.  ;now go through refusals in pcc
  1.  S AMHRRIEN=0 F  S AMHRRIEN=$O(^AUPNPREF("AC",DFN,AMHRRIEN)) Q:AMHRRIEN'=+AMHRRIEN  D
  1.  .Q:'$D(^AUPNPREF(AMHRRIEN,0))
  1.  .Q:$P(^AUPNPREF(AMHRRIEN,0),U,5)'=9999999.15
  1.  .Q:$P(^AUPNPREF(AMHRRIEN,0),U,6)'=AMHREXC
  1.  .S AMHRDATE=$P(^AUPNPREF(AMHRRIEN,0),U,3)
  1.  .Q:AMHRDATE=""
  1.  .Q:AMHRDATE>AMHRED
  1.  .Q:AMHRDATE<AMHRBD
  1.  .I $P(^AUPNPREF(AMHRRIEN,0),U,7)="R",'$D(AMHRREST(5)) Q
  1.  .I $P(^AUPNPREF(AMHRRIEN,0),U,7)="U",'$D(AMHRREST(6)) Q
  1.  .I $D(^XTMP("AMHRDV3",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)) Q
  1.  .S AMHRRES=$$VAL^XBDIQ1(9000022,AMHRRIEN,.07) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING" S:AMHRRES["NEGATIVE" AMHRRES="NEGATIVE"
  1.  .S AMHRCNT=AMHRCNT+1
  1.  .S ^XTMP("AMHRDV3",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
  1.  .S $P(^XTMP("AMHRDV3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,16)=$$PRVREF(AMHRRIEN)
  1.  .S $P(^XTMP("AMHRDV3",AMHRJ,AMHRH,"VSTS",AMHRCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
  1.  .S ^XTMP("AMHRDV3",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)=AMHRCNT
  1.  Q
  1. BHPPIN(R) ;
  1.  NEW %,%1
  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.  Q %1
  1. BHPPNAME(R) ;EP primary provider internal # from 200
  1.  NEW %,%1
  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)
  1.  I %1]"" Q %1
  1.  Q "UNKNOWN"
  1. SPRV(E) ;
  1.  I $P($G(^AUPNVXAM(E,12)),U,4) Q $$VAL^XBDIQ1(9000010.13,E,1204)
  1.  Q "UNKNOWN"
  1. PRVREF(R) ;
  1.  I $P($G(^AUPNPREF(R,12)),U,4)]"" Q $$VAL^XBDIQ1(9000022,R,1204)
  1.  Q "UNKNOWN"
  1. PPV(V) ;
  1.  NEW %
  1.  S %=$$PRIMPROV^APCLV(V,"N")
  1.  I %]"" Q %
  1.  Q "UNKNOWN"
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. EOP ;EP - End of page.
  1.  Q:$E(IOST)'="C"
  1.  Q:IO'=IO(0)
  1.  Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
  1.  NEW DIR
  1.  K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1.  W !
  1.  S DIR("A")="End of Report.  Press Enter",DIR(0)="E" D ^DIR
  1.  Q
  1.  ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;----------