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

BSDX41H.m

Go to the documentation of this file. 
  1. BSDX41H ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
  1.  ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
  1.  ;
  1. MEAS ; ******************** MEASUREMENTS * 9000010.01 *******
  1.  ; <SETUP>
  1.  Q:'$D(^AUPNVMSR("AA",APCHSPAT))
  1.  X APCHSBRK
  1.  ; <DISPLAY>
  1.  ;X APCHSCKP Q:$D(APCHSQIT)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
  1.  S APCHSMT="" F APCHSQ=0:0 S APCHSMT=$O(^AUPNVMSR("AA",APCHSPAT,APCHSMT)) Q:APCHSMT=""  S APCHSND2=APCHSNDM D MEASDTYP Q:$D(APCHSQIT)
  1.  ; <CLEANUP>
  1. MEASX K APCHSMT,APCHSMT2,APCHSMT3,APCHSDFN,APCHSND2,APCHSDAT
  1.  Q
  1. MEASDTYP S APCHSMT2=$S($D(^AUTTMSR(APCHSMT,0)):$P(^(0),U,1),1:APCHSMT) S APCHSMT3=APCHSMT2
  1.  S (APCHSIVD,APCHSDFN)="" F  S APCHSIVD=$O(^AUPNVMSR("AA",APCHSPAT,APCHSMT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  S APCHSND2=APCHSND2-1 Q:APCHSND2=-1  D MEASDSP
  1.  I APCHSMT3="" D
  1.  . ;X APCHSCKP Q:$D(APCHSQIT)
  1.  . S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
  1.  Q
  1. MEASDSP S APCHSDFN=$O(^AUPNVMSR("AA",APCHSPAT,APCHSMT,APCHSIVD,"")),Y=-APCHSIVD\1+9999999
  1.  X APCHSCVD
  1.  S APCHSDAT=Y
  1.  ;X APCHSCKP Q:$D(APCHSQIT)
  1.  S:APCHSNPG!(APCHSMT3]"") BSDXTMP=APCHSMT2
  1.  S APCHSMT3=""
  1.  S BSDXTMP=BSDXTMP_$$FILL^BSDX41(5-$L(BSDXTMP))_APCHSDAT
  1.  S BSDXTMP=BSDXTMP_$$FILL^BSDX541(18-$L(BSDXTMP))_$P(^AUPNVMSR(APCHSDFN,0),U,4)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1.  Q
  1.  ;
  1. IMMUN ; ******************** IMMUNIZATIONS * 9000010.11 *******
  1.  I +$$VER^BILOGO>7.1 D IMMBI2,REF Q  ;IHS/CMI/MWR  8/19/03, for Immunization v8.x
  1.  I $$BI^APCHS11C D IMMBI,REF Q  ;IHS/CMI/LAB - new imm package
  1.  ; <SETUP>
  1.  Q:'$D(^AUPNVIMM("AA",APCHSPAT))
  1.  ;X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK
  1.  ; <DISPLAY>
  1.  S APCHSITP="" F APCHSQ=0:0 S APCHSITP=$O(^AUPNVIMM("AA",APCHSPAT,APCHSITP)) Q:APCHSITP=""  D IMMDTYP
  1.  ; <CLEANUP>
  1. REF ; display refusals/contraindications from imm package and from PCC
  1.   S APCHY=0 F  S APCHY=$O(^BIPC("AC",APCHSPAT,APCHY)) Q:APCHY'=+APCHY  D
  1.  .S APCHX=0 F  S APCHX=$O(^BIPC("AC",APCHSPAT,APCHY,APCHX)) Q:APCHX'=+APCHX  D
  1.  ..S R=$P(^BIPC(APCHX,0),U,3)
  1.  ..Q:R=""
  1.  ..Q:'$D(^BICONT(R,0))
  1.  ..Q:$P(^BICONT(R,0),U,1)'["Refusal"
  1.  ..S D=$P(^BIPC(APCHX,0),U,4)
  1.  ..Q:D=""
  1.  ..S D=9999999-D
  1.  ..Q:D>APCHSDLM
  1.  ..;X APCHSCKP Q:$D(APCHSQIT)
  1.  ..S BSDXTMP=$$VAL^XBDIQ1(9002084.11,APCHX,.02)_" -- "_$$VAL^XBDIQ1(9002084.11,APCHX,.03)
  1.  ..S BSDXTMP=BSDXTMP_$$FILL^BSDX41(60-$L(BSDXTMP))_"("_$$DATE^APCHSMU($P(^BIPC(APCHX,0),U,4))_")"
  1.  ..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1.  ..Q
  1.  .Q
  1.  S APCHSFN=9999999.14,APCHST="" D DISPREF^BSDX41F
  1.  K APCHSFN,APCHST,APCHSS
  1. IMMUNX K APCHSITP,APCHSITX,APCHSITL,APCHSDFN,APCHSDAT,APCHSIVD,APCHSVDF
  1.  K APCHSIMC,APCHSIMR,APCHSN,APCHSIC,APCHSIR
  1.  K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE
  1.  Q
  1. IMMDTYP S APCHSITX=$P(^AUTTIMM(APCHSITP,0),U,2),APCHSITL=$L(APCHSITX)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
  1.  ;X APCHSCKP Q:$D(APCHSQIT)
  1.  S BSDXTMP=APCHSITX S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVIMM("AA",APCHSPAT,APCHSITP,APCHSIVD)) Q:'APCHSIVD  D IMMDSP
  1.  Q
  1. IMMDSP S APCHSDFN=0 F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVIMM("AA",APCHSPAT,APCHSITP,APCHSIVD,APCHSDFN)) Q:APCHSDFN=""  D IMMDSP2
  1.  Q
  1. IMMDSP2 S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
  1.  S APCHSN=^AUPNVIMM(APCHSDFN,0)
  1.  S APCHSVDF=$P(APCHSN,U,3) D GETSITEV^APCHSUTL S APCHSITE=APCHSNSH
  1.  S X=$P(APCHSN,U,6),Y=.06 D IMMGSET S APCHSIR=APCHSP
  1.  S X=$P(APCHSN,U,7),Y=.07 D IMMGSET S APCHSIC=APCHSP S:APCHSIC]"" APCHSIC="DO NOT REPEAT"
  1.  I APCHSIC]"",APCHSIR]"" S APCHSIR=APCHSIR_"; "
  1.  S APCHSIR=APCHSIR_APCHSIC
  1.  ;modified following line - LAB
  1.  ;X APCHSCKP Q:$D(APCHSQIT)
  1.  S:APCHSNPG BSDXTMP=APCHSITX
  1.  S BSDXTMP=BSDXTMP_$$FILL^BSDX41((APCHSITL+1)-$L(BSDXTMP))_$P(^AUPNVIMM(APCHSDFN,0),U,4)
  1.  S BSDXTMP=BSDXTMP_$$FILL^BSDX41(15-$L(BSDXTMP))_APCHSDAT
  1.  S BSDXTMP=BSDXTMP_$$FILL^BSDX41(25-$L(BSDXTMP))_$$AGE(APCHSPAT,$P(+^AUPNVSIT(APCHSVDF,0),"."),"P")
  1.  S BSDXTMP=BSDXTMP_$$FILL^BSDX41(34-$L(BSDXTMP))_APCHSITE
  1.  S BSDXTMP=BSDXTMP_$$FILL^BSDX41(65-$L(BSDXTMP))_APCHSIR
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1.  Q
  1. IMMGSET S Y=$G(^DD(9000010.11,Y,0)),Y=$P(Y,U,3)
  1.  S:'X Y=""
  1.  F APCHSQ=1:1 S APCHSP=$P(Y,";",APCHSQ) Q:APCHSP=""  I $P(APCHSP,":",1)=X S APCHSP=$P(APCHSP,":",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.  X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK
  1.  ;
  1.  ;
  1.  ;
  1.  NEW APCH31,APCHIMM,APCHBIER
  1.  S APCH31=$C(31)_$C(31),APCHIMM=""
  1.  D IMMFORC^BIRPC(.APCHIMM,APCHSPAT)
  1.  ;
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="  "_"IMMUNIZATION FORECAST:"_$C(30)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
  1.  ;
  1.  S APCH31="||"
  1.  D
  1.  .;---> Check for error in 2nd piece of return value.
  1.  .S APCHBIER=$P(APCHIMM,APCH31,2)
  1.  .;---> If there's an error, display it and quit.
  1.  .I APCHBIER]"" Q
  1.  .;
  1.  .;---> No error, so take 1st piece of return value and process it.
  1.  .S APCHIMM=$P(APCHIMM,APCH31,1)
  1.  .;
  1.  .NEW APCHX,APCHI F APCHX=1:1 S APCHI=$P(APCHIMM,"^",APCHX) Q:APCHI=""!($D(APCHSQIT))  D
  1.  ..;X APCHSCKP Q:$D(APCHSQIT)
  1.  ..S BSDXTMP="  "_$P(APCHI,"|")
  1.  ..S BSDXTMP=BSDXTMP_$$FILL^BSDX41(23-$L(BSDXTMP))_$P(APCHI,"|",2)
  1.  ..S BSDXTMP=BSDXTMP_$$FILL^BSDX41(36-$L(BSDXTMP))_$P(APCHI,"|",3)
  1.  ..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1.  ..Q
  1.  ;
  1. CONTRAS ;
  1.  ;
  1.  N APCHCONT S APCHCONT=""
  1.  ;
  1.  ;---> RPC to retrieve Contraindications.
  1.  D CONTRAS^BIRPC5(.APCHCONT,APCHSPAT)
  1.  ;
  1.  S APCH31="||"
  1.  ;---> If APCHBIER has a value, display it and quit.
  1.  S APCHBIER=$P(APCHCONT,APCH31,2)
  1.  I APCHBIER]"" D
  1.  .;X APCHSCKP Q:$D(APCHSQIT)
  1.  .;D EN^DDIOL("* "_APCHBIER,"","!!?5")
  1.  .G HX
  1.  ;
  1.  ;---> Set APCHC=to a string of Contraindications for this patient.
  1.  N APCHC S APCHC=$P(APCHCONT,APCH31,1)
  1.  I APCHC]"" D
  1.  .;X APCHSCKP Q:$D(APCHSQIT)
  1.  .S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
  1.  ;
  1.  ;---> Build Listmanager array from APCHC string.
  1.  ;
  1.  F I=1:1 S Y=$P(APCHC,U,I) Q:Y=""  D
  1.  .;---> Build display line for this Contraindication.
  1.  .N V S V="|",X="      "
  1.  .S:I=1 X=X_"* Contraindications:" S X=$$PAD(X,28)
  1.  .;
  1.  .;---> Display "Vaccine:  Date  Reason"
  1.  .S X=X_$P(Y,V,2)_":",X=$$PAD(X,40)_$P(Y,V,4)
  1.  .S X=$$PAD(X,53)_$P(Y,V,3)
  1.  .;---> Set formatted Contraindication line and index in ^TMP.
  1.  .;X APCHSCKP Q:$D(APCHSQIT)
  1.  .S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=X_$C(30)
  1.  .Q
  1.  ;
  1.  ;
  1.  ;
  1. HX ;
  1.  NEW APCHBIDE,I F I=8,26,27,60,33,44,57 S APCHBIDE(I)=""
  1.  ;call to get imm hx
  1.  D IMMHX^BIRPC(.APCHIMM,APCHSPAT,.APCHBIDE,,0)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="  "_"IMMUNIZATION HISTORY:"_$C(30)
  1.  ;
  1.  S APCH31="||"
  1.  S APCHBIER=$P(APCHIMM,APCH31,2)
  1.  I APCHBIER]"" Q  ;X APCHSCKP Q:$D(APCHSQIT)  D EN^DDIOL("* "_APCHBIER,"","!!?5") Q
  1.  S APCHIMM=$P(APCHIMM,APCH31,1)
  1.  NEW APCHI,APCHV,APCHX,APCHY,APCHZ
  1.  S APCHZ="",APCHV="|"
  1.  F APCHI=1:1 S APCHY=$P(APCHIMM,U,APCHI) Q:APCHY=""!($D(APCHSQIT))  D
  1.  .Q:$P(APCHY,APCHV)'="I"
  1.  .I $P(APCHY,APCHV,4)'=APCHZ D
  1.  ..;X APCHSCKP Q:$D(APCHSQIT)
  1.  ..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
  1.  ..S APCHZ=$P(APCHY,APCHV,4)
  1.  .NEW X,APCHSDG K %DT S X=$P(APCHY,APCHV,8),%DT="P" D ^%DT S APCHSDG=Y
  1.  .;X APCHSCKP Q:$D(APCHSQIT)
  1.  .S BSDXTMP="  "_$P(APCHY,APCHV,2)
  1.  .S BSDXTMP=BSDXTMP_$$FILL^BSDX41(22-$L(BSDXTMP))_$P(APCHY,APCHV,8)
  1.  .S BSDXTMP=BSDXTMP_$$FILL^BSDX41(34-$L(BSDXTMP))_$$AGE(APCHSPAT,APCHSDG,"P")
  1.  .S BSDXTMP=BSDXTMP_$$FILL^BSDX41(45-$L(BSDXTMP))_$E($P(APCHY,APCHV,3),1,20)
  1.  .S BSDXTMP=BSDXTMP_$$FILL^BSDX41(66-$L(BSDXTMP))_$P(APCHY,APCHV,5)
  1.  .S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1.  .I $P(APCHY,APCHV,6)]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(21)_"Reaction: "_$P(APCHY,APCHV,6)_$C(30)
  1.  .Q
  1.  ;----------
  1.  K APCHIMM,APCHY,APCHV,APCHBIDE,APCHZ
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  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. IMMBI2 ;EP
  1.  ;---> Call to Immunization Package v8.x to build local array of formatted
  1.  ;---> lines for Imm Health Summary Component.  ;IHS/CMI/MWR 8/19/03
  1.  ;---> Mike Remillard
  1.  ;
  1.  ;X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK
  1.  N APCHSARR S APCHSARR=""
  1.  D IMMBI^BIAPCHS(APCHSPAT,.APCHSARR)
  1.  ;first find out if VARICELLA is forecasted
  1.  N N,F S N=0,F=0
  1.  NEW F S (F,N)=0 F  S N=$O(APCHSARR(N)) Q:'N  D
  1.  .Q:APCHSARR(N,0)["IMMUNIZATION HISTORY:"
  1.  .I APCHSARR(N,0)["VARICELLA" S F=1  ;varicella forecast as due
  1.  .Q
  1.  S N=0
  1.  F  S N=$O(APCHSARR(N)) Q:'N  D  ;X APCHSCKP Q:$D(APCHSQIT)
  1.  .I APCHSARR(N,0)["IMMUNIZATION HISTORY" D
  1.  ..I F S X=$$PHCP(APCHSPAT) I X]"" D
  1.  ...S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
  1.  ...S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="Patient has a Hx of chicken pox not yet entered as a contraindication"_$C(30)
  1.  ...S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="in the Immunization Package."_$C(30)
  1.  ...S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=X_$C(30)
  1.  ...S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
  1.  .S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=APCHSARR(N,0)_$C(30)
  1.  D KILLALL^BIUTL8()
  1.  Q
  1. PHCP(P) ;EP
  1.  ;is there a personal history of chicken pox or is chicken pox on the problem list
  1.  NEW X,Y,Z,I,G
  1.  S G="",X=0 F  S X=$O(^AUPNPH("AC",P,X)) Q:X'=+X!(G)  D
  1.  .Q:'$D(^AUPNPH(X,0))
  1.  .S I=$P(^AUPNPH(X,0),U)
  1.  .Q:I=""
  1.  .;S I=$P($G(^ICD9(I,0)),U)  ;cmi/anch/maw 8/28/2007 orig line
  1.  .S I=$P($$ICDDX^ICDCODE(I),U,2)  ;cmi/anch/maw 8/28/2007 code set versioning
  1.  .Q:$E(I,1,3)'="052"
  1.  .S G=X
  1.  .Q
  1.  I G Q "Personal History: "_I_" - "_$$VAL^XBDIQ1(9000013,G,.04)
  1.  ;now check problem list
  1.  S X=0 F  S X=$O(^AUPNPH("AC",P,X)) Q:X'=+X!(G)  D
  1.  .Q:'$D(^AUPNPH(X,0))
  1.  .S I=$P(^AUPNPH(X,0),U)
  1.  .Q:I=""
  1.  .S I=$P($G(^ICD9(I,0)),U)
  1.  .Q:$E(I,1,3)'="052"
  1.  .S G=X
  1.  .Q
  1.  I G Q "Problem List: "_I_" - "_$$VAL^XBDIQ1(9000011,G,.05)
  1.  Q ""