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

APCDLIM.m

Go to the documentation of this file. 
  1. APCDLIM ; IHS/CMI/LAB - LIST IMMUNIZATION DATA ; 
  1.  ;;2.0;IHS PCC SUITE;**2,7,8**;MAY 14, 2009;Build 2
  1.  ;
  1.  W !?10,"Immunization Record",!
  1.  S APCDLIM("IMM")="" F  S APCDLIM("IMM")=$O(^AUPNVIMM("AA",APCDPAT,APCDLIM("IMM"))) Q:APCDLIM("IMM")=""  D IMM
  1.  K APCDLIM
  1.  Q
  1.  ;
  1. IMM ;
  1.  S APCDLIM("IMM NAME")=$P(^AUTTIMM(APCDLIM("IMM"),0),U,2),APCDLIM("IMM NAME LNTH")=$L(APCDLIM("IMM NAME")) W !,APCDLIM("IMM NAME") D DATE
  1.  Q
  1.  ;
  1. DATE ;
  1.  S APCDLIM("DATE")="" F  S APCDLIM("DATE")=$O(^AUPNVIMM("AA",APCDPAT,APCDLIM("IMM"),APCDLIM("DATE"))) Q:APCDLIM("DATE")=""  D DISP
  1.  Q
  1.  ;
  1. DISP ;
  1.  S APCDLIM("DFN")=0 F  S APCDLIM("DFN")=$O(^AUPNVIMM("AA",APCDPAT,APCDLIM("IMM"),APCDLIM("DATE"),APCDLIM("DFN"))) Q:APCDLIM("DFN")=""  D DISP2
  1.  Q
  1.  ;
  1. DISP2 ;
  1.  S Y=-APCDLIM("DATE")\1+9999999 S:Y]"" Y=+Y,Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+$E(Y,1,3)) S APCDLIM("PRINT DATE")=Y K Y
  1.  S APCDLIM("VISIT")=$P(^AUPNVIMM(APCDLIM("DFN"),0),U,3) D GETSITE
  1.  W ?(APCDLIM("IMM NAME LNTH")+4),$P(^AUPNVIMM(APCDLIM("DFN"),0),U,4),?17,APCDLIM("PRINT DATE")," ",APCDLIM("SITE"),!
  1.  Q
  1.  ;
  1. GETSITE ;
  1.  S APCDLIM("SITE")=$P(^AUPNVSIT(APCDLIM("VISIT"),0),U,6)
  1.  S APCDLIM("SITE")=$P($G(^DIC(4,APCDLIM("SITE"),0)),U)
  1.  I $P($G(^AUPNVSIT(APCDLIM("VISIT"),21)),U,1)]"" S APCDLIM("SITE")=$P(^(21),U)
  1.  S:APCDLIM("SITE")="" APCDLIM("SITE")="<null>"
  1.  Q
  1.  ;
  1. HSIMM ;EP - called from xbnew
  1. IMMUN ; ******************** IMMUNIZATIONS * 9000010.11 *******
  1.  I $$BI^APCHS11C D IMMBI Q  ;IHS/CMI/LAB - new imm package
  1.  ; <SETUP>
  1.  Q:'$D(^AUPNVIMM("AA",APCDTP))
  1.  ; <DISPLAY>
  1.  NEW APCDSITP,APCDSQ,APCDSITX,APCDSITL,APCDSIVD,APCDSDFN,APCDSN,APCHSVDF,APCDSITE,APCHSNSH,APCDSIR,APCDSP,APCDSIR,APCDSIC
  1.  S APCDSITP="" F APCDSQ=0:0 S APCDSITP=$O(^AUPNVIMM("AA",APCDTP,APCDSITP)) Q:APCDSITP=""  D IMMDTYP
  1.  ; <CLEANUP>
  1.  K APCHSITE,APCHSNAB,APCHSNFL,APCHSNSH,APCHSP,APCHSVDF,APCHSVSC
  1.  Q
  1. IMMDTYP S APCDSITX=$P(^AUTTIMM(APCDSITP,0),U,2),APCDSITL=$L(APCDSITX) W !,APCDSITX S APCDSIVD="" F APCDSQ=0:0 S APCDSIVD=$O(^AUPNVIMM("AA",APCDTP,APCDSITP,APCDSIVD)) Q:'APCDSIVD  D IMMDSP
  1.  Q
  1. IMMDSP S APCDSDFN=0 F APCDSQ=0:0 S APCDSDFN=$O(^AUPNVIMM("AA",APCDTP,APCDSITP,APCDSIVD,APCDSDFN)) Q:APCDSDFN=""  D IMMDSP2
  1.  Q
  1. IMMDSP2 S Y=-APCDSIVD\1+9999999 S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+($E(Y,1,3))) S APCDSDAT=Y
  1.  S APCDSN=^AUPNVIMM(APCDSDFN,0)
  1.  S APCHSVDF=$P(APCDSN,U,3) D GETSITEV^APCHSUTL S APCDSITE=APCHSNSH
  1.  S X=$P(APCDSN,U,6),Y=.06 D IMMGSET S APCDSIR=APCDSP
  1.  S X=$P(APCDSN,U,7),Y=.07 D IMMGSET S APCDSIC=APCDSP S:APCDSIC]"" APCDSIC="DO NOT REPEAT"
  1.  I APCDSIC]"",APCDSIR]"" S APCDSIR=APCDSIR_"; "
  1.  S APCDSIR=APCDSIR_APCDSIC
  1.  ;modified following line - LAB
  1.  W ?(APCDSITL+1),$P(^AUPNVIMM(APCDSDFN,0),U,4),?20,APCDSDAT,?28,$$AGE(APCDTP,$P(+^AUPNVSIT(APCHSVDF,0),"."),"P"),?37,APCDSITE,?65,APCDSIR,!
  1.  Q
  1. IMMGSET S Y=$G(^DD(9000010.11,Y,0)),Y=$P(Y,U,3)
  1.  S:'X Y=""
  1.  F APCDSQ=1:1 S APCDSP=$P(Y,";",APCDSQ) Q:APCDSP=""  I $P(APCDSP,":",1)=X S APCDSP=$P(APCDSP,":",2) Q
  1.  Q
  1.  ;
  1.  ;-----------
  1. AGE(DFN,D,F) ;(DFN) Given DFN, return Age. ; AUPN*93.2*3
  1.  I '$G(DFN) Q -1
  1.  I '$D(^DPT(DFN,0)) Q -1
  1.  I $$DOB^AUPNPAT(DFN)<0 Q -1
  1.  S:$G(D)="" D=DT
  1.  S:$G(F)="" F="Y"
  1.  NEW %
  1.  S %=$$FMDIFF^XLFDT(D,$$DOB^AUPNPAT(DFN))
  1.  I F="Y" Q %\365.25
  1.  ;beginning Y2K
  1.  ;NEW %1 S %1=%\365.25,%=$S(%1>2:%1_" YRS",%<31:%1_" DYS",1:%\30_" MOS") ;Y2000
  1.  NEW %1 S %1=%\365.25,%=$S(%1>2:%1_" YRS",%<31:%_" DYS",1:%\30_" MOS") ;Y2000
  1.  ;end Y2000
  1.  Q %
  1.  ;
  1.  ;
  1. IMMBI ;IHS/CMI/LAB - new subroutine for new imm package
  1.  S APCD31=$C(31)_$C(31),APCDIMM=""
  1. HX ;
  1.  ;---> Get Data Element 4 instead of 8 (no more Dose#, v8.0). ;CMI/ER/MWR 11/19/03
  1.  ;NEW APCDBIDE,I F I=8,26,27,60,33,44,57 S APCDBIDE(I)=""
  1.  NEW APCDBIDE,I F I=4,26,27,60,33,44,57 S APCDBIDE(I)=""
  1.  ;call to get imm hx
  1.  D IMMHX^BIRPC(.APCDIMM,APCDTP,.APCDBIDE)
  1.  W !?3,"IMMUNIZATION HISTORY:",!
  1.  ;
  1.  S APCDBIER=$P(APCDIMM,APCD31,2)
  1.  I APCDBIER]"" D EN^DDIOL("* "_APCDBIER,"","!!?5") Q
  1.  S APCDIMM=$P(APCDIMM,APCD31,1)
  1.  NEW APCDI,APCDV,APCDX,APCDY,APCDZ
  1.  S APCDZ="",APCDV="|"
  1.  F APCDI=1:1 S APCDY=$P(APCDIMM,U,APCDI) Q:APCDY=""!($D(APCDSQIT))  D
  1.  .Q:$P(APCDY,APCDV)'="I"
  1.  .I $P(APCDY,APCDV,4)'=APCDZ W ! S APCDZ=$P(APCDY,APCDV,4)
  1.  .NEW X,APCDSDG K %DT S X=$P(APCDY,APCDV,8),%DT="P" D ^%DT S APCDSDG=Y
  1.  .;---> Make room for vaccine combination names (v8.0). ;CMI/ER/MWR 11/19/03
  1.  .;W ?3,$P(APCDY,APCDV,2),?22,$P(APCDY,APCDV,8),?34,$$AGE(APCDTP,APCDSDG,"P"),?45,$E($P(APCDY,APCDV,3),1,20),?66,$P(APCDY,APCDV,5),!
  1.  .W ?3,$P(APCDY,APCDV,2),?24,$P(APCDY,APCDV,8),?36,$$AGE(APCDTP,APCDSDG,"P"),?47,$E($P(APCDY,APCDV,3),1,18),?66,$P(APCDY,APCDV,5),!
  1.  .I $P(APCDY,APCDV,6)]"" W ?22,"Reaction: ",$P(APCDY,APCDV,6),!
  1.  .Q
  1.  ;----------
  1.  K APCDIMM,APCDY,APCDV,APCDBIDE,APCDZ
  1.  Q
  1. PAD(D,L,C) ;EP
  1.  ;---> Pad the length of data to a total of L characters
  1.  ;---> by adding spaces to the end of the data.
  1.  ;     Example: S X=$$PAD("MIKE",7)  X="MIKE   " (Added 3 spaces.)
  1.  ;---> Parameters:
  1.  ;     1 - D  (req) Data to be padded.
  1.  ;     2 - L  (req) Total length of resulting data.
  1.  ;     3 - C  (opt) Character to pad with (default=space).
  1.  ;
  1.  Q:'$D(D) ""
  1.  S:'$G(L) L=$L(D)
  1.  S:$G(C)="" C=" "
  1.  Q $E(D_$$REPEAT^XLFSTR(C,L),1,L)
  1.  ;
  1.  ;
  1.  ;----------
  1. GETIMM ;EP - called from APCD IM (ADD) template
  1.  S APCDX=$$CREATE(APCDVSIT,APCDPAT)
  1.  I APCDX]"" W !!,APCDX,"   Immunization entry failed."
  1.  K Y,APCDX
  1.  Q
  1. CREATE(APCDV,APCDP) ;
  1.  K DIC
  1.  S DIC="^AUTTIMM(",DIC("S")="I $P(^(0),U,7)'=1",DIC(0)="AEMQ" D ^DIC
  1.  I Y=-1 Q "No immunization type selected."
  1.  K DIC
  1.  S DIC="^AUPNVIMM(",X=+Y,DIC(0)="L",DIADD=1,DLAYGO=9000010.11,DIC("DR")=".02////"_APCDP_";.03////"_APCDV
  1.  D FILE^DICN K DIADD,DLAYGO,DIC,DR
  1.  I Y=-1 Q "error creating V Immunization entry"
  1.  S DA=+Y,DIE="^AUPNVIMM(",DR=".05;.14;1204;1216////"_$$NOW^XLFDT D ^DIE
  1.  Q ""