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

APCPDR2.m

Go to the documentation of this file. 
  1. APCPDR2 ; IHS/TUCSON/LAB - OHPRD-TUCSON/EDE - VISIT PROCESSING FOR PCC TX TRANSACTIONS AUGUST 14, 1992 ; [ 03/29/04  7:51 AM ]
  1.  ;;2.0;IHS PCC DATA EXTRACTION SYSTEM;**1,3,4,6,7**;APR 03, 1998
  1.  ;IHS/CMI/LAB - patch 4 commented out 2N check in disc
  1.  ;IHS/CMI/LAB - patch 1 - reworked so delimited stat records only
  1.  ;
  1.  I $P(^AUTTSITE(1,0),U,16)]"",$P(^AUTTSITE(1,0),U,16)'="N",$P(^AUPNVSIT(APCP("V DFN"),0),U,23)=.5 S APCP("MFI")=$G(APCP("MFI"))+1,APCPV("DEP COUNT")=$P(APCPV("V REC"),U,9),APCPV("TYPE")=$P(APCPV("V REC"),U,3) Q
  1.  I $P(APCPV("V REC"),U,11),$P(APCPV("V REC"),U,14)="" S APCP("DEL NEVER SENT")=APCP("DEL NEVER SENT")+1,APCPV("DEP COUNT")=0,APCPV("TYPE")=$P(APCPV("V REC"),U,3) Q
  1.  D VISIT
  1.  I $D(APCPE) S APCPE("EDFN")=APCP("V DFN"),APCPE("FILE")=9000010,APCPV("T-TCODE")=99 D COUNT I $G(APCPV("SRV CAT"))="H" D RESET^APCPDR21
  1.  Q:$D(APCPE)
  1.  I APCPV("PATIENT NAME")["DEMO,PATIENT" S APCP("DEMO PAT")=$G(APCP("DEMO PAT"))+1 Q
  1.  S APCPV("IHS LOCATION CODE")=APCPV("IHS LOCATION CODE")_$E("      ",1,6-$L(APCPV("IHS LOCATION CODE")))
  1.  D PROCTX
  1.  K APCPE,APCPT,APCPH
  1.  Q
  1.  ;
  1. COUNT ;EP
  1.  I $D(APCPE("ERROR")) S APCP("ERROR COUNT")=APCP("ERROR COUNT")+1 D ^APCPERR Q
  1.  Q
  1. VISIT ;EP
  1.  S APCPV("TYPE")=$P(APCPV("V REC"),U,3),APCPV("DEP COUNT")=$P(APCPV("V REC"),U,9)
  1.  I 'APCPV("DEP COUNT"),'$P(APCPV("V REC"),U,11) S APCPE("ERROR")="E100" Q
  1.  I APCPV("TYPE")="" S APCPE("ERROR")="E130" Q
  1.  S APCPV("SRV CAT")=$P(APCPV("V REC"),U,7)
  1.  I APCPV("SRV CAT")="" S APCPE("ERROR")="E132" Q
  1.  S X=$P(APCPV("V REC"),U,8),APCPV("CLINIC CODE")=$S(X="":"",$D(^DIC(40.7,X,0)):$P(^DIC(40.7,X,0),U,2),1:"")
  1.  S APCPV("LOC DFN")=$P(APCPV("V REC"),U,6)
  1.  I APCPV("LOC DFN")="" S APCPE("ERROR")="E111" Q
  1.  S APCPV("IHS LOCATION CODE")=$P(^AUTTLOC(APCPV("LOC DFN"),0),U,10) I APCPV("IHS LOCATION CODE")="" S APCPE("ERROR")="E113" Q
  1.  S APCPV("T-LOCAS")=$E(APCPV("IHS LOCATION CODE"),1,4),APCPV("ELOC")=$E(APCPV("IHS LOCATION CODE"),5,6)
  1. DEM ;
  1.  D DEM^APCPDR21 ;check demographic data q:error found
  1.  Q:APCPV("PATIENT NAME")["DEMO,PATIENT"
  1.  Q:$D(APCPE)
  1.  S APCPV("T-INIT")="  "
  1.  ;get discharge date if hospitalization
  1.  D:$P(APCPV("V REC"),U,7)="H" FINDDSCH
  1.  Q
  1. FINDDSCH ;
  1.  S X=$O(^AUPNVINP("AD",APCP("V DFN"),"")) I X S APCPV("DISCHARGE DATE")=$J($P(^AUPNVINP(X,0),U),7) Q
  1.  S X=$O(^AUPNVCHS("AD",APCP("V DFN"),"")) I X S APCPV("DISCHARGE DATE")=$J($P(^AUPNVCHS(X,0),U,7),7) Q
  1.  Q
  1.  ;
  1. PROCTX ; process and generate appropriate statistical record
  1.  D PRIMTX
  1.  Q:$D(APCPE)
  1.  D STATMEGA
  1.  ;D CHA
  1.  Q
  1.  ;
  1. PRIMTX ;PROCESS PRIMARY TX (PCIS,APC OR INPT)
  1.  K APCPE
  1. INPT ;
  1.  I APCPV("SRV CAT")="H","CV"'[APCPV("TYPE"),'$P(^AUPNVSIT(APCP("V DFN"),0),U,11) D ^APCPAH D:$D(APCPE) RESET^APCPDR21 Q  ;IHS/CMI/LAB - line above replaced with this line
  1.  ;
  1. APC ;generate APC record
  1.  ;send all amb,observ,nursing home,day surg,chart rev,tele - per Larry Claycomb 2/14/96
  1.  ;I $D(APCPS("APC")),"AORSCT"[APCPV("SRV CAT") D ^APCPAPC ;IHS/CMI/LAB - commented out
  1.  I "AORSCT"[APCPV("SRV CAT"),'$P(^AUPNVSIT(APCP("V DFN"),0),U,11) D ^APCPAPC ;IHS/CMI/LAB - new line
  1.  Q
  1.  ;
  1. STATMEGA ;generate area mega database record
  1.  Q:'$D(APCPS("STAT"))
  1.  ;I "E"[APCPV("SRV CAT") S APCP("EVENTS")=$G(APCP("EVENTS"))+1 Q
  1.  ;I '$D(^AUPNVPOV("AD",APCP("V DFN"))),APCPV("SRV CAT")="I" S APCP("IN NO PP")=$G(APCP("IN NO PP"))+1 Q
  1.  ;I '$D(^AUPNVPOV("AD",APCP("V DFN"))),"CV"[APCPV("TYPE") S APCP("IN NO PP")=$G(APCP("IN NO PP"))+1 Q
  1.  ;I '$D(^AUPNVPRV("AD",APCP("V DFN"))),"CV"[APCPV("TYPE") S APCP("IN NO PP")=$G(APCP("IN NO PP"))+1 Q
  1.  ;I '$D(^AUPNVPRV("AD",APCP("V DFN"))),APCPV("SRV CAT")="I" S APCP("IN NO PP")=$G(APCP("IN NO PP"))+1 Q
  1.  I APCPV("SRV CAT")="H","CVO"'[APCPV("TYPE") D  Q:'Y
  1.  .S Y=0 S Z=$O(^AUPNVINP("AD",APCP("V DFN"),0))
  1.  .Q:'Z
  1.  .I $P($G(^AUPNVINP(Z,0)),U,15) Q
  1.  .S Y=1
  1.  D DELSTAT
  1.  Q
  1. DELCNT ;
  1.  S APCP("STAT")=APCP("STAT")+1,APCP("COUNT")=APCP("COUNT")+1
  1.  S ^BAPCDATA(APCP("COUNT"))=APCP("X")
  1.  Q
  1. DELSTAT ;generate new delimited format of the statistical record
  1.  S APCP("VISITS STAT")=$G(APCP("VISITS STAT"))+1
  1.  S APCPV("TX GENERATED")=1,^XTMP("APCP"_$S(APCPO("RUN")="NEW":"DR",APCPO("RUN")="REDO":"REDO",APCPO("RUN")="DATE":"SRE",1:"DR"),"MAIN TX",APCP("V DFN"))=APCP("MAIN TX DATE") ;IHS/CMI/LAB - patch 3
  1.  S APCP("X")=$$VREC(APCP("V DFN"),"STATISTICAL RECORD 1")
  1.  D DELCNT
  1.  S APCP("X")=$$VREC(APCP("V DFN"),"STATISTICAL RECORD 2")
  1.  D DELCNT
  1.  S APCP("X")=$$VREC(APCP("V DFN"),"STATISTICAL RECORD 3")
  1.  D DELCNT
  1.  S APCP("X")=$$VREC(APCP("V DFN"),"STATISTICAL RECORD 4")
  1.  D DELCNT
  1.  S APCP("X")=$$VREC(APCP("V DFN"),"STATISTICAL RECORD 5")
  1.  D DELCNT
  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 6",APCPV("CPT SET"),APCPV("CPT X"))
  1.  ..D DELCNT
  1.  ;MEDS
  1.  K APCPMED,APCPMX,APCPMC,APCPMD,APCPMNDC,APCPMCLS,APCPMQ
  1.  I 'APCPS("ORYX") D
  1.  .S (APCPMX,APCPMC)=0 F  S APCPMX=$O(^AUPNVMED("AD",APCP("V DFN"),APCPMX)) Q:APCPMX'=+APCPMX  D
  1.  ..S APCPMD=$P(^AUPNVMED(APCPMX,0),U) Q:'$D(^PSDRUG(APCPMD,0))
  1.  ..S APCPMC=APCPMC+1
  1.  ..S APCPMD=$P(^PSDRUG(APCPMD,0),U)
  1.  ..S APCPMQ=$P(^AUPNVMED(APCPMX,0),U,6)
  1.  ..S APCPMNDC=$P($G(^PSDRUG($P(^AUPNVMED(APCPMX,0),U),2)),U,4)
  1.  ..S APCPMCLS=$P(^PSDRUG($P(^AUPNVMED(APCPMX,0),U),0),U,2)
  1.  ..S APCP("X")=$$VREC(APCP("V DFN"),"STATISTICAL RECORD 7",APCPMC,APCPMD,APCPMNDC,APCPMCLS,APCPMQ)
  1.  ..D DELCNT
  1.  S APCPV("STAT TX GEN")=1
  1.  Q
  1.  ;
  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.  .I 'APCPS("ORYX") X ^APCPREC(APCPRIEN,11,APCPZ,1)
  1.  .I APCPS("ORYX"),$P(^APCPREC(APCPRIEN,11,APCPZ,0),U,3) S X=""
  1.  .I APCPS("ORYX"),'$P(^APCPREC(APCPRIEN,11,APCPZ,0),U,3) X ^APCPREC(APCPRIEN,11,APCPZ,1)
  1.  .S $P(APCPT,U,APCPY)=X
  1.  .;S LORICNT=$G(LORICNT)+1,^LORITEST(LORICNT)=APCPVIEN_"^"_$P(^APCPREC(APCPRIEN,11,APCPZ,0),U,1)_"^"_$P(^APCPREC(APCPRIEN,11,APCPZ,0),U,2)_"^"_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. 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