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

APCPREX2.m

Go to the documentation of this file. 
  1. APCPREX2 ; IHS/TUCSON/LAB - reexport in date range ; [ 12/16/03  3:16 PM ]
  1.  ;;2.0;IHS PCC DATA EXTRACTION;**3**;APR 03, 1998
  1.  ;
  1.  ;
  1. GENREC ;EP
  1. DELSTAT ;generate new delimited format of the statistical record
  1.  S APCPUSED=APCPUSED+1 ;total number of visits used
  1.  S APCP("X")=$$VREC(APCP("V DFN"),"STATISTICAL RECORD 1")
  1.  D SETTMP
  1.  S APCP("X")=$$VREC(APCP("V DFN"),"STATISTICAL RECORD 2")
  1.  D SETTMP
  1.  S APCP("X")=$$VREC(APCP("V DFN"),"STATISTICAL RECORD 3")
  1.  D SETTMP
  1.  ;cpt records
  1.  K AUPNCPT S X=$$CPT^AUPNCPT(APCP("V DFN"))
  1.  I $D(AUPNCPT) D
  1.  .S (X,APCPV("CPT COUNT"))=0 F  S X=$O(AUPNCPT(X)) Q:X'=+X  S APCPV("CPT COUNT")=APCPV("CPT COUNT")+1
  1.  .S APCPV("CPT RECS")=$S(APCPV("CPT COUNT")#25=0:APCPV("CPT COUNT")/25,1:(APCPV("CPT COUNT")\25)+1) ;IHS/CMI/LAB
  1.  .F APCPV("CPT X")=1:1:APCPV("CPT RECS") D
  1.  ..S P=1,Y=(APCPV("CPT X")*25)-25 K APCPV("CPT SET") F  S Y=$O(AUPNCPT(Y)) Q:Y=""!(Y>(APCPV("CPT X")*25))  S $P(APCPV("CPT SET"),U,P)=$P(AUPNCPT(Y),U)_"^" D  S P=P+2
  1.  ...Q:$P(AUPNCPT(Y),U,4)'=9000010.18
  1.  ...S E=$P(AUPNCPT(Y),U,5) S $P(APCPV("CPT SET"),U,(P+1))=$P($G(^AUPNVCPT(E,0)),U,16)
  1.  ..S APCP("X")=$$VREC(APCP("V DFN"),"STATISTICAL RECORD 4",APCPV("CPT SET"),APCPV("CPT X"))
  1.  ..D SETTMP
  1.  Q
  1.  ;
  1. SETTMP ;
  1.  S APCPTOTR=APCPTOTR+1
  1.  S ^APCPDATA(APCPTOTR)=APCP("X")
  1.  Q
  1. VREC(APCPVIEN,APCPRTYP,APCPVAR1,APCPVAR2,APCPVAR3,APCPVAR4,APCPVAR5,APCPVAR6) ;generate 1 record delimited format
  1.  S APCPVIEN(0)=^AUPNVSIT(APCPVIEN,0)
  1.  S DFN=$P(^AUPNVSIT(APCPVIEN,0),U,5)
  1.  NEW APCPRIEN S APCPRIEN=$O(^APCPREC("B",APCPRTYP,0))
  1.  I 'APCPRIEN Q ""
  1.  NEW APCPY,APCPT S APCPY=0,APCPT="" F  S APCPY=$O(^APCPREC(APCPRIEN,11,"B",APCPY)) Q:APCPY'=+APCPY  D
  1.  .S X=""
  1.  .NEW APCPZ S APCPZ=$O(^APCPREC(APCPRIEN,11,"B",APCPY,0))
  1.  .Q:'$D(^APCPREC(APCPRIEN,11,APCPZ,1))
  1.  .X ^APCPREC(APCPRIEN,11,APCPZ,1)
  1.  .S $P(APCPT,U,APCPY)=X
  1.  Q APCPT
  1. DATE(D) ;EP - return YYYYMMDD from internal fm format
  1.  ;IHS/CMI/LAB - added this for Y2K compliance and "^" pieced statistical record
  1.  I $G(D)="" Q ""
  1.  Q ($E(D,1,3)+1700)_$E(D,4,7)
  1. EXAM(V,N) ;EP - return nth v exam on this visit
  1.  I 'V Q ""
  1.  I '$D(^AUPNVSIT(V)) Q ""
  1.  I '$G(N) Q ""
  1.  NEW %,Y,P,C,Z
  1.  S (Z,P)="",(Y,C)=0
  1.  S Y=0 F  S Y=$O(^AUPNVXAM("AD",V,Y)) Q:Y'=+Y   S C=C+1 I C=N S P=$P(^AUPNVXAM(Y,0),U),Z=Y
  1.  I 'P Q P
  1.  I '$D(^AUTTEXAM(P)) Q ""
  1.  Q $P(^AUTTEXAM(P,0),U,2)
  1.  ;
  1. PED(V,N) ;EP - return nth v patient ed on this visit
  1.  I 'V Q ""
  1.  I '$D(^AUPNVSIT(V)) Q ""
  1.  I '$G(N) Q ""
  1.  NEW %,Y,P,C,Z
  1.  S (Z,P)="",(Y,C)=0
  1.  S Y=0 F  S Y=$O(^AUPNVPED("AD",V,Y)) Q:Y'=+Y   S C=C+1 I C=N S P=$P(^AUPNVPED(Y,0),U),Z=Y
  1.  I 'P Q P
  1.  I '$D(^AUTTEDT(P)) Q ""
  1.  Q $P(^AUTTEDT(P,0),U,2)
  1.  ;
  1. PHNAC(V) ;
  1.  I '$G(V) Q ""
  1.  I '$$PHN(V) Q ""  ;not a phn visit
  1.  I $P(^AUPNVSIT(V,0),U,7)="N" Q "03"
  1.  I $$CLINIC^APCLV(V,"C")=11 Q "01"
  1.  Q "02"
  1. PHN(V) ;
  1.  ;is one of the providers a CHN?
  1.  I '$G(V) Q ""
  1.  NEW X,%,D,N
  1.  I $$PRIMPROV^APCLV(V,"D")=13!($$PRIMPROV^APCLV(V,"D")=32) Q 1
  1.  S (X,%,N)=0 F  S X=$O(^AUPNVPRV("AD",V,X)) Q:X'=+X  I $P(^AUPNVPRV(X,0),U,4)'="P" S N=N+1 S D=$$SECPROV^APCLV(V,"D",N) I D=13!(D=32) S %=1
  1.  Q %
  1. RZERO(V,L) ;ep right zero fill 
  1.  NEW %,I
  1.  S %=$L(V),Z=L-% F I=1:1:Z S V=V_"0"
  1.  Q V
  1. LZERO(V,L) ;EP - left zero fill
  1.  NEW %,I
  1.  S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
  1.  Q V
  1. LBLK(V,L) ;left blank fill
  1.  NEW %,I
  1.  S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V
  1.  Q V
  1. RBLK(V,L) ;EP right blank fill
  1.  NEW %,I
  1.  S %=$L(V),Z=L-% F I=1:1:Z S V=V_" "
  1.  Q V