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

APCHS10.m

Go to the documentation of this file. 
  1. APCHS10 ; IHS/CMI/LAB - PART 10 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
  1.  ;;2.0;IHS PCC SUITE;**2,11**;MAY 14, 2009;Build 58
  1.  ;IHS/CMI/LAB - took screen out of education topics service cat
  1.  ;IHS/CMI/LAB - patch 11 added behavior code and obj to pt ed display
  1.  ;IHS/CMI/LAB - added dental ada codes for education to pt ed display (1310, 1320, 1330)
  1.  ;cmi/anch/maw 8/27/2007 code set versioning in PEDCHK and REORDER
  1.  ;
  1. PTED ; ********** PATIENT EDUCATION * 9000010.16 **********
  1.  ; <SETUP>
  1.  ;Q:'$D(^AUPNVPED("AA",APCHSPAT))
  1.  K APCHSDEN D DENTED
  1.  I '$D(^AUPNVPED("AA",APCHSPAT)),'$D(APCHSDEN) Q  ;no ada or v pt ed
  1.  X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK
  1.  ; <DISPLAY>
  1.  S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVPED("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  D ONEDATE
  1.  S APCHSIVD=0 F  S APCHSIVD=$O(APCHSDEN(APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)!('APCHSNDM)  S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y S APCHSDTU=0 D
  1.  .S APCHSDFN=0 F  S APCHSDFN=$O(APCHSDEN(APCHSIVD,"PED",APCHSDFN)) Q:APCHSDFN'=+APCHSDFN!($D(APCHSQIT))!('APCHSNDM)  D PEDCHK S APCHSNDM=APCHSNDM-APCHSDTU
  1.  .S APCHSDFN=0,APCHSCNT=0 F  S APCHSDFN=$O(APCHSDEN(APCHSIVD,"DEN",APCHSDFN)) Q:APCHSDFN'=+APCHSDFN!($D(APCHSQIT))!('APCHSNDM)  D
  1.  ..S APCHX=APCHSDEN(APCHSIVD,"DEN",APCHSDFN)
  1.  ..X APCHSCKP Q:$D(APCHSQIT)
  1.  ..W ! S APCHSVDF=$P(^AUPNVDEN(APCHSDFN,0),U,3)
  1.  ..Q:'$D(^AUPNVSIT(APCHSVDF,0))
  1.  ..D GETSITEV^APCHSUTL W:'APCHSCNT APCHSDAT,?10,APCHSNSH W ?23,"ADA: ",$P(^AUTTADA(APCHX,0),U)," - ",$E($P(^AUTTADA(APCHX,0),U,2),1,40),! S APCHSCNT=APCHSCNT+1
  1.  ..Q
  1.  ; <CLEANUP>
  1.  ;now display PTED refusals
  1.  S APCHST="EDUCATION",APCHSFN=9999999.09 D DISPREF^APCHS3C
  1.  K APCHST,APCHSFN
  1. PTEDX K APCHSIVD,APCHSDAT,APCHSDFN,APCHSFO,APCHSFAC,APCHSN,APCHSDTU,APCHSLVL,APCHSLVT,APCHSPED,APCHSPTB,APCHSQ,Y
  1.  K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSVDF,APCHSDEN,APCHSDE1,APCHSDE2,APCHSDE3,APCHX
  1.  Q
  1. ONEDATE S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVPED("AA",APCHSPAT,APCHSIVD,APCHSDFN)) Q:APCHSDFN=""  D
  1.  .S X=$P($G(^AUPNVPED(APCHSDFN,0)),U)
  1.  .Q:'X
  1.  .Q:'$D(^AUTTEDT(X,0))
  1.  .S APCHSDEN(APCHSIVD,"PED",APCHSDFN)=""
  1.  Q
  1. PEDCHK S APCHSN=^AUPNVPED(APCHSDFN,0)
  1.  S APCHSVDF=$P(APCHSN,U,3) D GETSITEV^APCHSUTL
  1.  X APCHSCKP Q:$D(APCHSQIT)  S:APCHSNPG APCHSDTU=0
  1.  I 'APCHSDTU W APCHSDAT S APCHSFO=""
  1.  I APCHSNSH=APCHSFO S APCHSFAC=""
  1.  E  S (APCHSFAC,APCHSFO)=APCHSNSH
  1.  S APCHSDTU=1
  1.  S APCHSPED=$P(APCHSN,U,1),APCHSPEM=$P(^AUTTEDT(APCHSPED,0),U,2),APCHSPED=$P(^AUTTEDT(APCHSPED,0),U,1)
  1.  S APCHSLVL=$P(APCHSN,U,6),APCHSLVT=""
  1.  I APCHSLVL]"" D
  1.  .  S APCHSLVT=$P(^DD(9000010.16,.06,0),U,3)
  1.  .  S APCHSLVT=$P(APCHSLVT,APCHSLVL_":",2)
  1.  .  S APCHSLVT=$P(APCHSLVT,";",1)
  1.  .  S:"^GOOD^FAIR^POOR^"[("^"_APCHSLVT_"^") APCHSLVT=APCHSLVT_" UNDERSTANDING"
  1.  .  ;S APCHSLVT="- "_APCHSLVT
  1.  .  Q
  1.  X APCHSCKP Q:$D(APCHSQIT)  W:APCHSNPG APCHSDAT W ?10,APCHSFAC,?23,$E(APCHSPEM,1,12),?35,$E(APCHSPED,1,35),$S($P(APCHSN,U,7)="":"",$P(APCHSN,U,7)="I":" - (IND)",$P(APCHSN,U,7)="G":" - (GRP)",1:""),!
  1.  I APCHSLVT]"" W ?35,APCHSLVT,!
  1.  I $P(APCHSN,U,13)]""!($P(APCHSN,U,14)]"") D
  1.  .X APCHSCKP Q:$D(APCHSQIT)
  1.  .W ?23,"Behavior Code: ",$$VAL^XBDIQ1(9000010.16,APCHSDFN,.13),?51,"Objectives Met: ",$P(APCHSN,U,14),!
  1.  I $P($G(^AUPNVPED(APCHSDFN,11)),U)]"" S APCHSTXT=$P(^AUPNVPED(APCHSDFN,11),U),APCHSNRQ="",APCHSICL=23 D PRTTXT^APCHSUTL
  1.  ;cmi/anch/maw 8/27/2007 mods follow for code set versioning
  1.  ;I $P($G(^AUPNVPED(APCHSDFN,11)),U)="",$P(APCHSN,U,4)]"" S APCHSTXT=$P(^ICD9($P(APCHSN,U,4),0),U,3),APCHSNRQ="",APCHSICL=23 D PRTTXT^APCHSUTL
  1.  N APCHSVDT
  1.  S APCHSVDT=$P($P($G(^AUPNVSIT(APCHSVDF,0)),U),".")  ;get visit date
  1.  I $P($G(^AUPNVPED(APCHSDFN,11)),U)="",$P(APCHSN,U,4)]"" S APCHSTXT=$P($$ICDDX^ICDEX($P(APCHSN,U,4),APCHSVDT),U,4),APCHSNRQ="",APCHSICL=23 D PRTTXT^APCHSUTL
  1.  ;cmi/anch/maw 8/27/2007 end of mods
  1.  I $P(APCHSN,U,11)]"" S APCHSTXT=$P(APCHSN,U,11),APCHSNRQ="",APCHSICL=23 D PRTTXT^APCHSUTL Q
  1.  Q
  1.  ;
  1. MRPTED ; ********** MOST RECENT PATIENT EDUCATION * 9000010.16 **********
  1.  ; <SETUP>
  1.  ;Q:'$D(^AUPNVPED("AA",APCHSPAT))
  1.  K APCHSDEN D DENTEDL
  1.  I '$D(^AUPNVPED("AA",APCHSPAT)),'$D(APCHSDEN) Q  ;no ada or v pt ed
  1.  X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK
  1.  ; <DISPLAY>
  1.  K APCHSPTB
  1.  ;S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVPED("AA",APCHSPAT,APCHSIVD)) Q:'APCHSIVD  S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y D ONEDAY Q:$D(APCHSQIT)
  1.  ;IHS/CMI/LAB - PATCH 9 modified this to look at date range and max visit limits
  1.  S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVPED("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  D ONEDAY
  1.  S APCHSIVD=0 F  S APCHSIVD=$O(APCHSDEN(APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)!('APCHSNDM)  S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y S APCHSDTU=0 D
  1.  .S APCHSDFN=0 F  S APCHSDFN=$O(APCHSDEN(APCHSIVD,"PED",APCHSDFN)) Q:APCHSDFN'=+APCHSDFN!($D(APCHSQIT))!('APCHSNDM)  D PEDCHK S APCHSNDM=APCHSNDM-APCHSDTU
  1.  .S APCHSDFN=0,APCHSCNT=0 F  S APCHSDFN=$O(APCHSDEN(APCHSIVD,"DEN",APCHSDFN)) Q:APCHSDFN'=+APCHSDFN!($D(APCHSQIT))!('APCHSNDM)  D
  1.  ..S APCHX=APCHSDEN(APCHSIVD,"DEN",APCHSDFN)
  1.  ..X APCHSCKP Q:$D(APCHSQIT)
  1.  ..W ! S APCHSVDF=$P(^AUPNVDEN(APCHSDFN,0),U,3) D GETSITEV^APCHSUTL W:'APCHSCNT APCHSDAT,?10,APCHSNSH W ?23,"ADA: ",$P(^AUTTADA(APCHX,0),U)," - ",$E($P(^AUTTADA(APCHX,0),U,2),1,40),! S APCHSCNT=APCHSCNT+1
  1.  ..Q
  1.  ; <CLEANUP>
  1.  ;now display PTED refusals
  1.  S APCHST="EDUCATION",APCHSFN=9999999.09 D DISPREF^APCHS3C
  1.  K APCHST,APCHSFN
  1. MRPTEDX K APCHSPTB,APCHSEVT
  1.  K APCHSIVD,APCHSDAT,APCHSDFN,APCHSFO,APCHSFAC,APCHSN,APCHSDTU,APCHSLVL,APCHSLVT,APCHSPED
  1.  K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSVDF
  1.  Q
  1.  ;
  1. ONEDAY  ;
  1.  S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVPED("AA",APCHSPAT,APCHSIVD,APCHSDFN)) Q:'APCHSDFN  D
  1.  .S X=$P($G(^AUPNVPED(APCHSDFN,0)),U)
  1.  .Q:X=""
  1.  .Q:'$D(^AUTTEDT(X,0))
  1.  .S APCHSEVT=+^AUPNVPED(APCHSDFN,0) I '$D(APCHSPTB(APCHSEVT)) S APCHSPTB(APCHSEVT)="",APCHSDEN(APCHSIVD,"PED",APCHSDFN)=""
  1.  Q
  1. MRPE ;EP - called from component
  1.  ; <SETUP>
  1.  ;Q:'$D(^AUPNVPED("AA",APCHSPAT))
  1.  K APCHSDEN D DENTAL
  1.  I '$D(^AUPNVPED("AA",APCHSPAT)),'$D(APCHSDEN) Q  ;no ada or v pt ed
  1.  X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK
  1.  ; <DISPLAY>
  1.  K APCHSPTB
  1.  ;S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVPED("AA",APCHSPAT,APCHSIVD)) Q:'APCHSIVD  S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y D ONEDAY Q:$D(APCHSQIT)
  1.  ;IHS/CMI/LAB - PATCH 9 modified this to look at date range and max visit limits
  1.  S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVPED("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)!('APCHSNDM)  D
  1.  .S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y  S APCHSDTU=0 D MRPEOD Q:$D(APCHSQIT)  S APCHSNDM=APCHSNDM-APCHSDTU Q:'APCHSNDM
  1.  D REORDER
  1.  ; <CLEANUP>
  1.  ;now display PTED refusals
  1.  S APCHST="EDUCATION",APCHSFN=9999999.09 D DISPREF^APCHS3C
  1.  K APCHST,APCHSFN
  1. MRPEX K APCHSPTB,APCHSEVT,APCHSDSP,APCHSX
  1.  K APCHSIVD,APCHSDAT,APCHSDFN,APCHSFO,APCHSFAC,APCHSN,APCHSDTU,APCHSLVL,APCHSLVT,APCHSPED
  1.  K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSVDF
  1.  Q
  1.  ;
  1. MRPEOD ;
  1.  S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVPED("AA",APCHSPAT,APCHSIVD,APCHSDFN)) Q:'APCHSDFN  S APCHSEVT=+^AUPNVPED(APCHSDFN,0) I '$D(APCHSPTB(APCHSEVT)) S APCHSPTB(APCHSEVT)=APCHSIVD_U_APCHSDFN,APCHSDTU=1
  1.  Q
  1. REORDER ;reorder by name and print
  1.  S APCHSEVT=0 F  S APCHSEVT=$O(APCHSPTB(APCHSEVT)) Q:APCHSEVT'=+APCHSEVT  I $D(^AUTTEDT(APCHSEVT,0)) S APCHSDSP($P(^AUTTEDT(APCHSEVT,0),U))=APCHSPTB(APCHSEVT)
  1.  S APCHSX="" F  S APCHSX=$O(APCHSDSP(APCHSX)) Q:APCHSX=""!($D(APCHSQIT))  D
  1.  .S APCHSDFN=$P(APCHSDSP(APCHSX),U,2)
  1.  .S APCHSIVD=$P(APCHSDSP(APCHSX),U) S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
  1.  .I $P(APCHSDSP(APCHSX),U,3)="D" S APCHSN=^AUPNVDEN(APCHSDFN,0)
  1.  .E  S APCHSN=^AUPNVPED(APCHSDFN,0)
  1.  .S APCHSVDF=$P(APCHSN,U,3) D GETSITEV^APCHSUTL
  1.  .I $P(APCHSDSP(APCHSX),U,3)="D" D  Q
  1.  ..X APCHSCKP Q:$D(APCHSQIT)
  1.  ..W $E(APCHSX,1,43),"  ADA Code: ",$P(^AUTTADA($P(^AUPNVDEN(APCHSDFN,0),U),0),U),?57,APCHSDAT,?67,APCHSNSH,! Q
  1.  .S APCHSLVL=$P(APCHSN,U,6),APCHSLVT=""
  1.  .I APCHSLVL]"" D
  1.  ..  S APCHSLVT=$P(^DD(9000010.16,.06,0),U,3)
  1.  ..  S APCHSLVT=$P(APCHSLVT,APCHSLVL_":",2)
  1.  ..  S APCHSLVT=$P(APCHSLVT,";",1)
  1.  ..  S:"^GOOD^FAIR^POOR^"[("^"_APCHSLVT_"^") APCHSLVT=APCHSLVT_" UNDERSTANDING"
  1.  ..  S APCHSLVT="- "_APCHSLVT
  1.  .X APCHSCKP Q:$D(APCHSQIT)  W APCHSX,"  ",$S($P(APCHSN,U,7)="":"",$P(APCHSN,U,7)="I":" - (IND)",$P(APCHSN,U,7)="G":" - (GRP)",1:""),"  ",APCHSLVT,?57,APCHSDAT,?67,APCHSNSH,!
  1.  .I $P(APCHSN,U,13)]""!($P(APCHSN,U,14)]"") D
  1.  ..X APCHSCKP Q:$D(APCHSQIT)
  1.  ..W ?23,"Behavior Code: ",$$VAL^XBDIQ1(9000010.16,APCHSDFN,.13),?51,"Objectives Met: ",$P(APCHSN,U,14),!
  1.  .I $P($G(^AUPNVPED(APCHSDFN,11)),U)]"" S APCHSTXT=$P(^AUPNVPED(APCHSDFN,11),U),APCHSNRQ="",APCHSICL=5 D PRTTXT^APCHSUTL
  1.  .;cmi/anch/maw 8/27/2007 mods follow for code set versioning
  1.  .;I $P($G(^AUPNVPED(APCHSDFN,11)),U)="",$P(APCHSN,U,4)]"" S APCHSTXT=$P(^ICD9($P(APCHSN,U,4),0),U,3),APCHSNRQ="",APCHSICL=5 D PRTTXT^APCHSUTL
  1.  .N APCHSVDT
  1.  .S APCHSVDT=$P($P($G(^AUPNVSIT(APCHSVDF,0)),U),".")  ;get visit date
  1.  .I $P($G(^AUPNVPED(APCHSDFN,11)),U)="",$P(APCHSN,U,4)]"" S APCHSTXT=$P($$ICDDX^ICDEX($P(APCHSN,U,4),APCHSVDT),U,4),APCHSNRQ="",APCHSICL=5 D PRTTXT^APCHSUTL
  1.  .;cmi/anch/maw 8/27/2007 end of mods
  1.  .I $P(APCHSN,U,11)]"" S APCHSTXT=$P(APCHSN,U,11),APCHSNRQ="",APCHSICL=5 D PRTTXT^APCHSUTL Q
  1.  ;now print all dental ADA
  1.  Q
  1. DENTEDL ;gather up last of each
  1.  K APCHSDEN S APCHSDTU=0
  1.  S APCHSDE1=$O(^AUTTADA("B",1310,0))
  1.  S APCHSDE2=$O(^AUTTADA("B",1320,0))
  1.  S APCHSDE3=$O(^AUTTADA("B",1330,0))
  1.  S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVDEN("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  D
  1.  .S APCHSDFN="" F  S APCHSDFN=$O(^AUPNVDEN("AA",APCHSPAT,APCHSIVD,APCHSDFN)) Q:'APCHSDFN  D
  1.  ..S X=$P($G(^AUPNVDEN(APCHSDFN,0)),U) I X=APCHSDE1!(X=APCHSDE2)!(X=APCHSDE3) I '$D(APCHSDEN("DEN",X)) S APCHSDEN(APCHSIVD,"DEN",APCHSDFN)=$P(^AUPNVDEN(APCHSDFN,0),U),APCHSDEN("DEN",X)=""
  1.  .Q
  1.  Q
  1. DENTED ;gather up all 1310, 1320, 1330
  1.  K APCHSDEN S APCHSDTU=0
  1.  S APCHSDE1=$O(^AUTTADA("B",1310,0))
  1.  S APCHSDE2=$O(^AUTTADA("B",1320,0))
  1.  S APCHSDE3=$O(^AUTTADA("B",1330,0))
  1.  S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVDEN("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  D
  1.  .S APCHSDFN="" F  S APCHSDFN=$O(^AUPNVDEN("AA",APCHSPAT,APCHSIVD,APCHSDFN)) Q:'APCHSDFN  D
  1.  ..S X=$P($G(^AUPNVDEN(APCHSDFN,0)),U) I X=APCHSDE1!(X=APCHSDE2)!(X=APCHSDE3) S APCHSDEN(APCHSIVD,"DEN",APCHSDFN)=$P(^AUPNVDEN(APCHSDFN,0),U),APCHSDTU=APCHSDTU+1
  1.  .Q
  1.  Q
  1. DENTAL ;
  1.  K APCHSDEN,APCHSDSP
  1.  K APCHSDEN S APCHSDTU=0
  1.  S APCHSDE1=$O(^AUTTADA("B",1310,0))
  1.  S APCHSDE2=$O(^AUTTADA("B",1320,0))
  1.  S APCHSDE3=$O(^AUTTADA("B",1330,0))
  1.  S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVDEN("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  D
  1.  .S APCHSDFN="" F  S APCHSDFN=$O(^AUPNVDEN("AA",APCHSPAT,APCHSIVD,APCHSDFN)) Q:'APCHSDFN  D
  1.  ..S X=$P($G(^AUPNVDEN(APCHSDFN,0)),U) I X=APCHSDE1!(X=APCHSDE2)!(X=APCHSDE3) I '$D(APCHSDEN("DEN",X)) S APCHSDSP($P(^AUTTADA(X,0),U,2))=APCHSIVD_U_APCHSDFN_U_"D",APCHSDEN("DEN",X)=""
  1.  .Q