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

APCLV06.m

Go to the documentation of this file. 
  1. APCLV06 ; IHS/CMI/LAB - provider functions ;
  1.  ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1.  ;
  1.  ;IHS/TUCSON/LAB - add parameter to pass back event date&time on provider entry 05/19/97 patch 1
  1. PRIMPROV ;EP - primary provider in many different formats
  1.  I 'V Q -1
  1.  I '$D(^AUPNVSIT(V)) Q -1
  1.  NEW %,Y,P,Z ;IHS/TUCSON/LAB - added ,Z patch 1 5/19/97
  1.  S P="",Y=0 F  S Y=$O(^AUPNVPRV("AD",V,Y)) Q:Y'=+Y  I $P(^AUPNVPRV(Y,0),U,4)="P" S P=$P(^AUPNVPRV(Y,0),U),Z=Y ;IHS/TUCSON/LAB - added ,Z=Y patch 1 05/19/97
  1.  I 'P Q P
  1.  I $P(^DD(9000010.06,.01,0),U,2)[200,'$D(^VA(200,P)) Q -1
  1.  I $P(^DD(9000010.06,.01,0),U,2)[6,'$D(^DIC(6,P)) Q -1
  1.  I $G(F)="" S F="N"
  1.  S %="" D @F
  1.  Q %
  1.  ;
  1. SECPROV ;EP
  1.  I 'V Q -1
  1.  I '$D(^AUPNVSIT(V)) Q -1
  1.  I '$G(N) Q -1
  1.  NEW %,Y,P,Z ;IHS/TUCSON/LAB - PATCH 1
  1.  S P="",(C,Y)=0 F  S Y=$O(^AUPNVPRV("AD",V,Y)) Q:Y'=+Y  I $P(^AUPNVPRV(Y,0),U,4)'="P" S C=C+1 I C=N S P=$P(^AUPNVPRV(Y,0),U),Z=Y  ;IHS/TUCSON/LAB - patch 1
  1.  I 'P Q P
  1.  I $P(^DD(9000010.06,.01,0),U,2)[200,'$D(^VA(200,P)) Q -1
  1.  I $P(^DD(9000010.06,.01,0),U,2)[6,'$D(^DIC(6,P)) Q -1
  1.  I $G(F)="" S F="N"
  1.  S %="" D @F
  1.  Q %
  1.  ;
  1. PROV ;EP
  1.  NEW Z,C,%,S
  1.  S (C,Y)=0 F  S Y=$O(^AUPNVPRV("AD",V,Y)) Q:Y'=+Y   S C=C+1 S APCLV(C)="",P=$P(^AUPNVPRV(Y,0),U) D
  1.  .I F=99 D  Q
  1.  ..F I=1:1 S S=$T(@I) Q:S=""  S %="" D @I S $P(APCLV(C),U,I)=%
  1.  .I F[";" D  Q
  1.  ..F J=1:1 S I=$P(F,";",J) Q:I=""  I I'=99 S %="" D @I S $P(APCLV(C),U,J)=%
  1.  .S %="",I=F D @I S $P(APCLV(C),U)=%
  1.  .Q
  1.  Q
  1. I ;EP
  1.  S %=P Q
  1. T ;EP
  1.  S %=$S($P(^DD(9000010.06,.01,0),U,2)[200:$P($G(^VA(200,P,0)),U,2),1:$P(^DIC(6,P,0),U,2)) Q
  1. A ;EP
  1.  S %=$S($P(^DD(9000010.06,.01,0),U,2)[200:$P($G(^VA(200,P,9999999)),U),1:$P($G(^DIC(6,P,9999999)),U)) Q
  1. B ;EP
  1.  S %=$S($P(^DD(9000010.06,.01,0),U,2)[200:$P($G(^VA(200,P,9999999)),U),1:$P($G(^DIC(6,P,9999999)),U))
  1.  Q:%=""
  1.  S %=$$EXTSET^XBFUNC(200,9999999.01,%)
  1.  Q
  1. D ;EP
  1.  D F
  1.  Q:%=""
  1.  S %=$P($G(^DIC(7,%,9999999)),U)
  1.  Q
  1.  ;
  1. E ;EP
  1.  S %=$$VAL^XBDIQ1($S($P(^DD(9000010.06,.01,0),U,2)[200:200,1:6),P,$S($P(^DD(9000010.06,.01,0),U,2)[200:53.5,1:2))
  1.  Q
  1. F ;EP
  1.  S %=$$VALI^XBDIQ1($S($P(^DD(9000010.06,.01,0),U,2)[200:200,1:6),P,$S($P(^DD(9000010.06,.01,0),U,2)[200:53.5,1:2))
  1.  Q
  1. C ;EP
  1.  S %=$S($P(^DD(9000010.06,.01,0),U,2)[200:$P($G(^VA(200,P,9999999)),U,2),1:$P($G(^DIC(6,P,9999999)),U,2)) Q
  1. N ;EP
  1.  S %=$S($P(^DD(9000010.06,.01,0),U,2)[200:$P($G(^VA(200,P,0)),U),1:$P($G(^DIC(16,P,0)),U)) Q
  1. O ;EP
  1.  NEW A D A Q:%=""  S A=%,%="" D D Q:%=""  S %=A_% Q
  1. P ;EP
  1.  NEW A D A Q:%=""  S A=% NEW D D D Q:%=""  S D=%,%="" D C Q:%=""  S %=A_D_% Q
  1. G ;EP - event date&time IHS/TUCSON/LAB - added this subroutine patch 1 05/19/97
  1.  S %=$P($G(^AUPNVPRV(Z,12)),U) Q
  1.  ;
  1. 1 ;
  1.  S %=$$VD^APCLV($P(^AUPNVPRV(Y,0),U,3),"I")
  1.  Q
  1. 2 ;
  1.  S %=$$VD^APCLV($P(^AUPNVPRV(Y,0),U,3),"S")
  1.  Q
  1. 3 ;
  1.  S %=$P(^AUPNVPRV(Y,0),U,2)
  1.  Q
  1. 4 ;
  1.  S %=$$PATIENT^APCLV($P(^AUPNVPRV(Y,0),U,3),"E")
  1.  Q
  1. 5 ;
  1.  S %=$P(^AUPNVPRV(Y,0),U)
  1.  Q
  1. 6 D T Q
  1. 7 D A Q
  1. 8 D B Q
  1. 9 D C Q
  1. 10 D D Q
  1. 11 D E Q
  1. 12 D F Q
  1. 13 D N Q
  1. 14 D O Q
  1. 15 D P Q
  1. 16 S %=$P(^AUPNVPRV(Y,0),U,4) Q
  1. 17 S %=$$VAL^XBDIQ1(9000010.06,Y,.04) Q
  1. 18 S %=$$VALI^XBDIQ1(9000010.06,Y,.05) Q
  1. 19 S %=$$VAL^XBDIQ1(9000010.06,Y,.05) Q
  1. 20 S %=$$VAL^XBDIQ1(9000010.06,Y,1201) Q
  1. ATTPHY ;EP
  1.  I 'V Q -1
  1.  I '$D(^AUPNVSIT(V)) Q -1
  1.  NEW %,Y,P
  1.  S P="",(C,Y)=0 F  S Y=$O(^AUPNVPRV("AD",V,Y)) Q:Y'=+Y  I $P(^AUPNVPRV(Y,0),U,5)="A" S P=$P(^AUPNVPRV(Y,0),U)
  1.  I 'P Q P
  1.  I $P(^DD(9000010.06,.01,0),U,2)[200,'$D(^VA(200,P)) Q -1
  1.  I $P(^DD(9000010.06,.01,0),U,2)[6,'$D(^DIC(6,P)) Q -1
  1.  I $G(F)="" S F="N"
  1.  S %="" D @F
  1.  Q %
  1.  ;
  1. MIDWIFE ;EP
  1.  I 'V Q -1
  1.  I '$D(^AUPNVSIT(V)) Q -1
  1.  I $P(^AUPNVSIT(V,0),U,7)'="H" Q ""
  1.  NEW %,Y,P
  1.  S P="",(C,Y)=0 F  S Y=$O(^AUPNVPRV("AD",V,Y)) Q:Y'=+Y  S P=$P(^AUPNVPRV(Y,0),U)
  1.  I 'P Q P
  1.  I $P(^DD(9000010.06,.01,0),U,2)[200,'$D(^VA(200,P)) Q -1
  1.  I $P(^DD(9000010.06,.01,0),U,2)[6,'$D(^DIC(6,P)) Q -1
  1.  S %="" D D
  1.  Q $S(%=17:1,1:"")
  1.  ;
  1.  ;return a 1 if one of the providers is a midwife (ihs code=17)