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

APCLDV31.m

Go to the documentation of this file. 
  1. APCLDV31 ; IHS/CMI/LAB - list IPV/DV screenings ;
  1.  ;;2.0;IHS PCC SUITE;**8,10**;MAY 14, 2009;Build 88
  1.  ;
  1.  ;
  1. PROC ;
  1.  S APCLCNT=0
  1.  S APCLH=$H,APCLJ=$J
  1.  K ^XTMP("APCLDV3",APCLJ,APCLH)
  1.  D XTMP^APCLOSUT("APCLDV3","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:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
  1.  .I APCLCOMT="O",$$COMMRES^AUPNPAT(DFN,"I")'=APCLCOMT("ONE") Q  ;not in community
  1.  .I APCLCOMT="S" S X=$$COMMRES^AUPNPAT(DFN,"E") I '$D(APCLTAX(X)) Q  ;not in comm taxonomy
  1.  .I APCLSEX'[$P(^DPT(DFN,0),U,2) Q  ;not right gender
  1.  .I APCLDESP]"",$P(^AUPNPAT(DFN,0),U,14)'=APCLDESP Q  ;not correct designated provider
  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.  S APCLEIEN=0 F  S APCLEIEN=$O(^AUPNVXAM("AC",DFN,APCLEIEN)) Q:APCLEIEN'=+APCLEIEN  D
  1.  .Q:'$D(^AUPNVXAM(APCLEIEN,0))
  1.  .Q:$P(^AUPNVXAM(APCLEIEN,0),U)'=APCLEXC  ;not ipv/dv
  1.  .S APCLVIEN=$P(^AUPNVXAM(APCLEIEN,0),U,3)
  1.  .Q:'APCLVIEN
  1.  .S APCLDATE=$P($P($G(^AUPNVSIT(APCLVIEN,0)),U),".")
  1.  .Q:APCLDATE=""
  1.  .Q:APCLDATE>APCLED
  1.  .Q:APCLDATE<APCLBD
  1.  .I APCLLOCT="O",$P(^AUPNVSIT(APCLVIEN,0),U,6)'=APCLLOCT("ONE") Q
  1.  .I APCLLOCT="S",$$VALI^XBDIQ1(9999999.06,$P(^AUPNVSIT(APCLVIEN,0),U,6),.05)'=APCLLOCT("SU") Q
  1.  .S X=$$AGE^AUPNPAT(DFN,APCLDATE)
  1.  .I $D(APCLAGET),X>$P(APCLAGET,"-",2) Q
  1.  .I $D(APCLAGET),X<$P(APCLAGET,"-",1) Q
  1.  .;clinic check
  1.  .I $D(APCLCLNT) S X=$P(^AUPNVSIT(APCLVIEN,0),U,8) Q:X=""  Q:'$D(APCLCLNT(X))
  1.  .;bh exclude/include check
  1.  .I 'APCLEXBH S C=$$CLINIC^APCLV(APCLVIEN,"C") I C=14!(C=43)!(C=48)!(C="C4")!(C="C9") Q
  1.  .;result check
  1.  .S APCLRES=$$VAL^XBDIQ1(9000010.13,APCLEIEN,.04) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
  1.  .I APCLRES="NEGATIVE",'$D(APCLREST(1)) Q
  1.  .I APCLRES="PRESENT",'$D(APCLREST(2)) Q
  1.  .I APCLRES="PAST",'$D(APCLREST(3)) Q
  1.  .I APCLRES="",'$D(APCLREST(6)) Q
  1.  .;PRIMARY PROVIDER CHECK
  1.  .S X=$$PRIMPROV^APCLV(APCLVIEN,"I")
  1.  .I $D(APCLPROV),X="" Q  ;want only certain primary providers on visit
  1.  .I $D(APCLPROV),APCLPROV'=X Q  ;want one provider and it's not this one
  1.  .I APCLPPUN,X'="" Q  ;want only unknown and this one has a primary provider
  1.  .S X=$P($G(^AUPNVXAM(APCLEIEN,12)),U,4)
  1.  .I $D(APCLSPRV),X="" Q  ;want only certain SCR providers on visit
  1.  .I $D(APCLSPRV),APCLSPRV'=X Q  ;want one provider and it's not this one
  1.  .I APCLSPUN,X'="" Q  ;want only unknown and this one has a SCR provider
  1.  .S ^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN)=""
  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
  1.  S APCLRIEN=0 F  S APCLRIEN=$O(^AUPNPREF("AC",DFN,APCLRIEN)) Q:APCLRIEN'=+APCLRIEN  D
  1.  .Q:'$D(^AUPNPREF(APCLRIEN,0))
  1.  .Q:$P(^AUPNPREF(APCLRIEN,0),U,5)'=9999999.15
  1.  .Q:$P(^AUPNPREF(APCLRIEN,0),U,6)'=APCLEXC
  1.  .S APCLDATE=$P(^AUPNPREF(APCLRIEN,0),U,3)
  1.  .Q:APCLDATE=""
  1.  .Q:APCLDATE>APCLED
  1.  .Q:APCLDATE<APCLBD
  1.  .S X=$$AGE^AUPNPAT(DFN,APCLDATE)
  1.  .I $D(APCLAGET),X>$P(APCLAGET,"-",2) Q
  1.  .I $D(APCLAGET),X<$P(APCLAGET,"-",1) Q
  1.  .S APCLRES=$$VAL^XBDIQ1(9000022,APCLRIEN,.07) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING"
  1.  .I APCLRES["REFUSED",'$D(APCLREST(4)) Q  ;do not want refusals
  1.  .I APCLRES["UNABLE",'$D(APCLREST(5)) Q  ;do not want unables
  1.  .S X=$P($G(^AUPNPREF(APCLRIEN,12)),U,4)
  1.  .I $D(APCLSPRV),X="" Q  ;want only certain SCR providers on visit
  1.  .I $D(APCLSPRV),APCLSPRV'=X Q  ;want one provider and it's not this one
  1.  .I APCLSPUN,X'="" Q  ;want only unknown and this one has a SCR provider
  1.  .S ^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN)=""
  1.  ;Q:$D(^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN))   ;already got this patient so no need to go on
  1. BH ;now go through BH
  1.  Q:'APCLEXBH  ;not if user doesn't want to
  1.  S APCLSD=$$FMADD^XLFDT(APCLBD,-1),APCLSD=APCLSD_".9999"
  1.  F  S APCLSD=$O(^AMHREC("AF",DFN,APCLSD)) Q:APCLSD'=+APCLSD!($P(APCLSD,".")>APCLED)  D
  1.  .S APCLBIEN=0 F  S APCLBIEN=$O(^AMHREC("AF",DFN,APCLSD,APCLBIEN)) Q:APCLBIEN'=+APCLBIEN  D
  1.  ..S APCLDATE=$P(APCLSD,".")
  1.  ..Q:'$D(^AMHREC(APCLBIEN,0))
  1.  ..Q:$P($G(^AMHREC(APCLBIEN,14)),U)=""
  1.  ..Q:APCLDATE>APCLED
  1.  ..Q:APCLDATE<APCLBD
  1.  ..I APCLLOCT="O",$P(^AMHREC(APCLBIEN,0),U,4)'=APCLLOCT("ONE") Q
  1.  ..I APCLLOCT="S",$$VALI^XBDIQ1(9999999.06,$P(^AMHREC(APCLBIEN,0),U,4),.05)'=APCLLOCT("SU") Q
  1.  ..S X=$$AGE^AUPNPAT(DFN,APCLDATE)
  1.  ..I $D(APCLAGET),X>$P(APCLAGET,"-",2) Q
  1.  ..I $D(APCLAGET),X<$P(APCLAGET,"-",1) Q
  1.  ..;clinic check
  1.  ..I $D(APCLCLNT) S X=$P(^AMHREC(APCLBIEN,0),U,25) Q:X=""  Q:'$D(APCLCLNT(X))
  1.  ..;result check
  1.  ..S APCLRES=$$VAL^XBDIQ1(9002011,APCLBIEN,1401) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
  1.  ..I APCLRES="NEGATIVE",'$D(APCLREST(1)) Q
  1.  ..I APCLRES="PRESENT",'$D(APCLREST(2)) Q
  1.  ..I APCLRES="PAST",'$D(APCLREST(3)) Q
  1.  ..I APCLRES["REFUSED",'$D(APCLREST(4)) Q  ;do not want refusals
  1.  ..I APCLRES["UNABLE",'$D(APCLREST(5)) Q  ;do not want unables
  1.  ..I APCLRES="",'$D(APCLREST(6)) Q
  1.  ..;PRIMARY PROVIDER CHECK
  1.  ..S X=$$BHPPIN(APCLBIEN)
  1.  ..I $D(APCLPROV),X="" Q  ;want only certain primary providers on visit
  1.  ..I $D(APCLPROV),APCLPROV'=X Q  ;want one provider and it's not this one
  1.  ..I APCLPPUN,X'="" Q  ;want only unknown and this one has a primary provider
  1.  ..S X=$P($G(^AMHREC(APCLBIEN,14)),U,2)
  1.  ..I $D(APCLSPRV),X="" Q  ;want only certain SCR providers on visit
  1.  ..I $D(APCLSPRV),APCLSPRV'=X Q  ;want one provider and it's not this one
  1.  ..I APCLSPUN,X'="" Q  ;want only unknown and this one has a SCR provider
  1.  ..S ^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN)=""
  1.  Q
  1.  ;
  1. GETSCR ;
  1.  K ^XTMP("APCLDV3",APCLJ,APCLH,"VSTS")
  1.  S DFN=0 F  S DFN=$O(^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN)) Q:DFN'=+DFN  D GETSCR1
  1.  Q
  1. GETSCR1 ;
  1.  ;go through exam IPV, then through AUPNPREF for refusals
  1.  S APCLEIEN=0 F  S APCLEIEN=$O(^AUPNVXAM("AC",DFN,APCLEIEN)) Q:APCLEIEN'=+APCLEIEN  D
  1.  .Q:'$D(^AUPNVXAM(APCLEIEN,0))
  1.  .Q:$P(^AUPNVXAM(APCLEIEN,0),U)'=APCLEXC
  1.  .S APCLVIEN=$P(^AUPNVXAM(APCLEIEN,0),U,3)
  1.  .Q:'APCLVIEN
  1.  .S APCLDATE=$P($P($G(^AUPNVSIT(APCLVIEN,0)),U),".")
  1.  .Q:APCLDATE=""
  1.  .Q:APCLDATE>APCLED
  1.  .Q:APCLDATE<APCLBD
  1.  .I 'APCLEXBH S C=$$CLINIC^APCLV(APCLVIEN,"C") I C=14!(C=43)!(C=48)!(C="C4")!(C="C9") Q
  1.  .S APCLCNT=APCLCNT+1
  1.  .S APCLRES=$$VAL^XBDIQ1(9000010.13,APCLEIEN,.04) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
  1.  .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
  1.  .S $P(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,10)=$$VAL^XBDIQ1(9000010,APCLVIEN,.08)
  1.  .S $P(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,15)=APCLVIEN
  1.  .S $P(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,16)=$$SPRV(APCLEIEN)
  1.  .S $P(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
  1.  .S ^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN,APCLDATE)=APCLCNT
  1.  ;now go through refusals in pcc
  1.  S APCLRIEN=0 F  S APCLRIEN=$O(^AUPNPREF("AC",DFN,APCLRIEN)) Q:APCLRIEN'=+APCLRIEN  D
  1.  .Q:'$D(^AUPNPREF(APCLRIEN,0))
  1.  .Q:$P(^AUPNPREF(APCLRIEN,0),U,5)'=9999999.15
  1.  .Q:$P(^AUPNPREF(APCLRIEN,0),U,6)'=APCLEXC
  1.  .S APCLDATE=$P(^AUPNPREF(APCLRIEN,0),U,3)
  1.  .Q:APCLDATE=""
  1.  .Q:APCLDATE>APCLED
  1.  .Q:APCLDATE<APCLBD
  1.  .S APCLRES=$$VAL^XBDIQ1(9000022,APCLRIEN,.07) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
  1.  .S APCLCNT=APCLCNT+1
  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
  1.  .S $P(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,16)=$$PRVREF(APCLRIEN)
  1.  .S $P(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
  1.  .S ^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN,APCLDATE)=APCLCNT
  1.  ;now go through BH
  1.  Q:'APCLEXBH  ;not if user doesn't want to
  1.  S APCLSD=$$FMADD^XLFDT(APCLBD,-1),APCLSD=APCLSD_".9999"
  1.  F  S APCLSD=$O(^AMHREC("AF",DFN,APCLSD)) Q:APCLSD'=+APCLSD!($P(APCLSD,".")>APCLED)  D
  1.  .S APCLBIEN=0 F  S APCLBIEN=$O(^AMHREC("AF",DFN,APCLSD,APCLBIEN)) Q:APCLBIEN'=+APCLBIEN  D
  1.  ..S APCLDATE=$P(APCLSD,".")
  1.  ..Q:'$D(^AMHREC(APCLBIEN,0))
  1.  ..Q:$P($G(^AMHREC(APCLBIEN,14)),U)=""
  1.  ..Q:APCLDATE>APCLED
  1.  ..Q:APCLDATE<APCLBD
  1.  ..I $D(^XTMP("APCLDV3",APCLJ,APCLH,"PTS",DFN,APCLDATE)) Q
  1.  ..S APCLCNT=APCLCNT+1
  1.  ..S APCLRES=$$VAL^XBDIQ1(9002011,APCLBIEN,1401) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"
  1.  ..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
  1.  ..S $P(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,10)=$$VAL^XBDIQ1(9002011,APCLBIEN,.25)
  1.  ..S $P(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,15)=APCLBIEN
  1.  ..S $P(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,16)=$$VAL^XBDIQ1(9002011,APCLBIEN,1402)
  1.  ..S $P(^XTMP("APCLDV3",APCLJ,APCLH,"VSTS",APCLCNT),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
  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.  ;get 1204 if it exists, otherwise take 1202
  1.  I $P($G(^AUPNVXAM(E,12)),U,4) Q $$VAL^XBDIQ1(9000010.13,E,1204)
  1.  I $P($G(^AUPNVXAM(E,12)),U,2) Q $$VAL^XBDIQ1(9000010.13,E,1202)
  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.  ;----------