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

VENPCC1C.m

Go to the documentation of this file. 
  1. VENPCC1C ; IHS/OIT/GIS - MORE DATA MINING FOR ENCOUNTER FORMS 09 Mar 2004 8:15 AM ;
  1.  ;;2.6;PCC+;;NOV 12, 2007
  1.  ;
  1.  ; ONLY THE x FIELDS ARE POPULTED HERE UNDER VER 2.5.  NEW CODE IS IN VENPCCC
  1.  ; ART PKG FOR ALLERGIES IS SUPPORTED HERE
  1.  ; 
  1. XSET(SS,DFN,MIEN,MMF,CLASS,DEFEF) ; EP-SET MAIL MERGE FIELDS INTO TMP ARRAY
  1.  N PTYPE,X,VAL,TAG,TMP
  1.  S PTYPE=$P($G(^VEN(SS,MIEN,0)),U,9)
  1.  S TMP=$NA(^TMP("VEN PRNT",$J,1))
  1.  I '$$OK(SS,DFN,MIEN,PTYPE,CLASS,DEFEF) Q 0 ; FIELD FAILED TO MATCH PATIENT TYPE
  1.  S X=^VEN(SS,MIEN,0)
  1.  S VAL=$P(X,U)
  1.  S TAG=$G(^VEN(SS,MIEN,1))
  1.  I TAG'="",TAG?1.8UN1"^VENPCC"1.2UN X "I $L($T("_TAG_"))" I  X ("N X S VAL=$$"_TAG_"(DFN)") ; COMPUTED VALUE ;  TO PREVENT PROBLEMS CAUSED BY INVALID DATABASE ENTRY
  1.  I SS=7.94 S ^TMP("VEN PRNT",$J,1,MMF)=$P(X,U,4)_VAL_$P(X,U,5) Q 1
  1.  S ^TMP("VEN PRNT",$J,1,MMF)=VAL
  1. C1 S %=$P(X,U,6) I %'="" S @TMP@(MMF_"a")=% ; CODE #1
  1. C2 S %=$P(X,U,7) I %'="" S @TMP@(MMF_"b")=% ; CODE #2
  1.  Q 1
  1.  ; 
  1. OK(SS,DFN,MIEN,PTYPE,CLASS,DEFEF) ; EP-CHECK FOR PATIENT TYPE MATCH
  1.  N TAG,X,FORM
  1.  I PTYPE'=CLASS Q 0
  1.  S TAG=$G(^VEN(SS,MIEN,2)) I TAG="" Q 1
  1.  X ("S X=$$"_TAG_"(DFN)")
  1.  Q X
  1.  ; 
  1. ALLERG(APCHSPAT) ; EP-ALLERGIES
  1.  N APCHSDFN,IIEN,ICD,TOT,OK,MAX,APCHSP,APCHSNKA
  1.  I $P($G(^VEN(7.5,$$CFG^VENPCCU,0)),U,23) D ART^VENPCC1L(APCHSPAT) Q  ; USE THE ADVERSE RXN TRACKING PKG, VER 2.5
  1.  S APCHSDFN="",TOT=0,MAX=$P($G(^VEN(7.41,+$G(DEFEF),2)),U,5) I 'MAX S MAX=5
  1.  F  Q:TOT=(MAX+1)  S APCHSDFN=$O(^AUPNPROB("AC",+$G(APCHSPAT),APCHSDFN)) Q:'APCHSDFN  D
  1.  . S IIEN=+$P($G(^AUPNPROB(APCHSDFN,0)),U)
  1.  . S APCHSP=$P($G(^ICD9(IIEN,0)),U)
  1.  . I $L(APCHSP) S APCHSNKA=0 D PROBACHK^APCHS40 I $T,'APCHSNKA D SETA(APCHSDFN)
  1.  . Q
  1.  Q
  1.  ; 
  1. SETA(PIEN) ;
  1.  N NARR,NIEN,MAXNARR
  1.  S MAXNARR=$P($G(^VEN(7.41,$G(DEFEF),14)),U,6) I 'MAXNARR S MAXNARR=32 ; MAX STG LENGTH
  1.  S NIEN=+$P($G(^AUPNPROB(PIEN,0)),U,5)
  1.  S NARR=$P($G(^AUTNPOV(NIEN,0)),U)
  1.  I '$L(NARR) Q
  1.  S TOT=TOT+1
  1.  I TOT=(MAX+1) S @TMP@(1,("a"_MAX))="More allergies on Hlth Summary!" Q
  1.  S @TMP@(1,("a"_TOT))=$E(NARR,1,MAXNARR)
  1.  Q
  1.  ; 
  1. INS(DFN)          ;  EP-- send the patient dfn and get back 3p elig
  1.  Q $$TPC(DFN)
  1.  ; 
  1. CLASS(DFN) ; EP-GIVEN THE DFN RETURN THE PATIENT CLASS FOR SITE PREFERENCES
  1.  ; 1=INFANT,2=CHILD,3=ADULT MALE,4=ADULT FEMALE
  1.  N AGE,SEX,DOB,X
  1.  S X=$P($G(^DPT(DFN,0)),U,2,3),DOB=$P(X,U,2),SEX=$P(X,U)
  1.  I DOB,$L(SEX)
  1.  E  Q ""
  1.  S AGE=(DT-DOB)\10000
  1.  S X=$S(AGE<2:1,AGE<13:2,SEX="M":3,1:4)
  1.  Q X
  1.  ; 
  1. IF ; EP-ENABLE IMMUNIZATION FORECASTING AT SITES THAT SUPPORT IMMUNIZATION FORECASTING
  1.  I $L($T(VER^BILOGO)),$$VER^BILOGO>7.99,$L($T(IMMBI^BIAPCHS)) N TMP,% S TMP="IMM",%=$$NEWIMM^VENPCCS2(DFN) K @TMP,% Q  ; FOR IMM PKG 8.0 ; PATCHED BY GIS/ITSC
  1.  N I,TOT,X,Y,Z,%,N,LINE,BIDE,IMM,GRP,DATE,PRE,POST,TMP
  1.  S TMP=$NA(^TMP("VEN PRNT",$J,1))
  1.  S (LINE,PRE,POST)="",TOT=7
  1.  S %=$O(^VEN(7.94,"B","IMMUNIZATIONS",0)) I % S PRE=$P($G(^VEN(7.94,%,0)),U,4),POST=$P($G(^VEN(7.94,%,0)),U,5)
  1.  F I=8,26,27,60,33,44,57 S BIDE(I)=""
  1.  D IMMHX^BIRPC(.LINE,DFN,.BIDE)
  1.  F I=9:1:25 S @TMP@("h"_I)="" ; CLEAR OUT OLD VALUES FOR IMMUNIZATIONS
  1.  S Z=$L(LINE,U)-1
  1.  F N=1:1:Z S X=$P(LINE,U,N) I $L(X) D
  1.  . S IMM=$P(X,"|",2),DATE=$P(X,"|",8),GRP=$P(X,"|",4)
  1.  . I $L(IMM),$L(DATE),$L(GRP)
  1.  . E  Q
  1.  . S GRP(GRP)=PRE_IMM_"   "_DATE_POST
  1.  . Q
  1.  S GRP="" F TOT=9:1 S GRP=$O(GRP(GRP)) Q:GRP=""  S @TMP@("h"_TOT)=GRP(GRP)
  1.  Q
  1.  ;
  1. IX(X,CMD,IEN) ; EP-1=SET, 2=MMF, 3=DELETE
  1.  I $G(X)="" Q
  1.  I '$D(^VEN(7.93,+$G(IEN),0)) Q
  1.  I +$G(CMD)<1,+$G(CMD)>4 Q
  1.  N STG,MMF,SET,%
  1.  S STG=^VEN(7.93,IEN,0)
  1.  I CMD#2 S SET=X,MMF=$P($G(^VEN(7.42,+$P(STG,U,3),0)),U)
  1.  E  S MMF=$P($G(^VEN(7.42,X,0)),U),SET=$P(STG,U,2)
  1.  I 'SET!(MMF="") Q
  1.  I CMD<3 S ^VEN(7.93,"AS",SET,MMF,IEN)="" Q
  1.  K ^VEN(7.93,"AS",SET,MMF,IEN)
  1.  Q
  1.  ; 
  1. AX(X,CMD,IEN) ; EP-1=SET, 2=OGRP, 3=PGRP, 4=DELETE
  1.  I $G(X)="" Q
  1.  I '$D(^VEN(7.93,+$G(IEN),0)) Q
  1.  I +$G(CMD)<1,+$G(CMD)>4 Q
  1.  N STG,PGRP,SET,%,GRP,FLD
  1.  S STG=^VEN(7.93,IEN,0)
  1.  I CMD=1 S SET=X,PGRP=$P(STG,U,9),FLD=$P(STG,U,8)
  1.  I CMD=2 S FLD=X,SET=$P(STG,U,2),PGRP=$P(STG,U,9)
  1.  I CMD=3 S PGRP=X,SET=$P(STG,U,2),FLD=$P(STG,U,8)
  1.  I CMD=4 S PGRP=$P(STG,U,9),SET=$P(STG,U,2),FLD=$P(STG,U,8)
  1.  I SET,$L(FLD),PGRP
  1.  E  Q
  1.  S GRP=PGRP_$E(FLD)
  1.  I CMD<4 S ^VEN(7.93,"AX",SET,GRP,IEN)="" Q
  1.  K ^VEN(7.93,"AX",SET,GRP,IEN)
  1.  Q
  1.  ; 
  1. OSET(DEFEF) ; EP - RETURN SET IEN IF THE TEMPLATE IS ASSOCIATED WITH A SET
  1.  I '$G(DEFEF) Q 0
  1.  I '$O(^VEN(7.92,0)) Q 0
  1.  I '$O(^VEN(7.93,"AS",0)) Q 0
  1.  N OSET
  1.  S OSET=+$P($G(^VEN(7.41,+$G(DEFEF),0)),U,9)
  1.  Q OSET
  1.  ; 
  1. TPC(DFN) ; EP-THIRD PARTY COVERAGE
  1.  I '$D(^DPT(DFN)) Q ""
  1.  N A,B,C,STG
  1.  S A=$$PVT(DFN),B=$$MCR(DFN),C=$$MCD(DFN),STG=""
  1.  I $L(A) S STG=A
  1.  I $L(STG),$L(B) S STG=A_", "_B
  1.  I '$L(A),$L(B) S STG=B
  1.  I $L(STG),$L(C) S STG=STG_", "_C
  1.  I '$L(STG),$L(C) S STG=C
  1.  S STG=$TR(STG,U,",")
  1.  Q STG
  1.  ; 
  1. PVT(DFN) ; EP-PRIVATE INSURANCE
  1.  N TPIEN,IIEN,NAME,INO,D1,D2,%,STG,STATUS
  1.  S TPIEN=0,STG=""
  1.  F  S TPIEN=$O(^AUPNPRVT(DFN,11,TPIEN)) Q:'TPIEN  S %=$G(^AUPNPRVT(DFN,11,TPIEN,0)) I $L(%) D
  1.  . S IIEN=+%,INO=$P(%,U,2),D1=$P(%,U,6),D2=$P(%,U,7)
  1.  . S NAME=$P($G(^AUTNINS(IIEN,0)),U) I '$L(NAME) Q
  1.  . I D1,D1>DT Q
  1.  . I D2,D2<DT Q
  1.  . I $L(STG) S STG=STG_U
  1.  . S STG=STG_NAME_" ("_INO_")"
  1.  . S STATUS=$P($G(^AUTNINS(IIEN,1)),U,7)
  1.  . I STATUS>2 S STG=STG_$S(STATUS=3:" [UNVERIFIED]",STATUS=4:" [UNBILLABLE]",1:"")
  1.  . Q
  1.  Q STG
  1.  ; 
  1. MCD(DFN) ; EP-MEDICAID ; SHOW EXPIRATION DATE IF MCD IS CURRENT
  1.  N %,Y,MIEN,DIEN,D1,D2,STG,MAXDT
  1.  S MIEN=999999999999,STG="",MAXDT=0
  1.  F  S MIEN=$O(^AUPNMCD("B",DFN,MIEN),-1) Q:'MIEN  S DIEN=9999999 F  S DIEN=$O(^AUPNMCD(MIEN,11,DIEN),-1) Q:'DIEN  D  ; ALSO MANAGES DUPLICATE RECORDS PROPERLY
  1.  . S %=$G(^AUPNMCD(MIEN,11,DIEN,0)) I '$L(%) Q
  1.  . S D1=+%,D2=$P(%,U,2)
  1.  . I D1'>MAXDT Q  ; ONLY CHECK THE LATEST RECORD
  1.  . S MAXDT=D1
  1.  . I D2 S Y=D2 X ^DD("DD")
  1.  . I D2,DT>D2 S STG="Medicaid expired "_Y Q
  1.  . I D2 S STG="Medicaid (expires "_Y_")" Q
  1.  . S STG="Medicaid (expires ??)"
  1.  . Q
  1.  Q STG ; STG WILL ALWAYS CONTAIN THE MCD STATUS FOR THE LATEST RECORD
  1.  ; 
  1. MCR(DFN) ; EP-MEDICARE
  1.  N %,MIEN,DIEN,D1,D2
  1.  S MIEN=$O(^AUPNMCR("B",DFN,999999999),-1) I 'MIEN Q "" ; MANAGES DUPLICATE RECORDS PROPERLY
  1.  S DIEN=$O(^AUPNMCR(MIEN,11,999999999),-1) I 'DIEN Q ""
  1.  S %=$G(^AUPNMCR(MIEN,11,DIEN,0)) I '$L(%) Q ""
  1.  S D1=+%,D2=$P(%,U,2)
  1.  I D1,D1>DT Q ""
  1.  I D2,D2<DT Q ""
  1.  Q "Medicare"
  1.  ; 
  1. SPEC(DFN,DEFEF) ; EP-GET DATA FOR OCXS
  1.  N CIEN,EIEN,MM,PCE,HIEN,HDR,TAG,VAL,X
  1.  S CIEN=0 F  S CIEN=$O(^VEN(7.62,"AB",+$G(DEFEF),CIEN)) Q:'CIEN  D
  1.  . S EIEN=0 F  S EIEN=$O(^VEN(7.62,CIEN,3,"B",EIEN)) Q:'EIEN  D
  1.  .. S TAG=$G(^VEN(7.61,EIEN,1)) I '$L(TAG) Q
  1.  .. S X=$G(^VEN(7.61,EIEN,0)) I X="" Q
  1.  .. S HIEN=$P(X,U,2) I 'HIEN Q
  1.  .. S PCE=$P(X,U,3) I 'PCE Q
  1.  .. S HDR=$P($G(^VEN(7.42,HIEN,0)),U) I HDR="" Q
  1.  .. X ("S VAL=$$"_TAG_"(DFN)")
  1.  .. S X=$G(SPECHOLD(HDR))
  1.  .. S $P(X,"\",PCE)=VAL
  1.  .. S SPECHOLD(HDR)=X
  1.  .. Q
  1.  . Q
  1.  Q
  1.  ;