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

APCHS0.m

Go to the documentation of this file. 
  1. APCHS0 ; IHS/CMI/LAB - PCC HEALTH SUMMARY - MAIN DRIVER PART 2 ;
  1.  ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1.  ;
  1.  ; ***** CALLED ONLY FROM APCHS: OUTSIDE CALLS USE EN^APCHS
  1.  ; ***** REQUIRES APCHSPAT,APCHSTYP,DUZ,DUZ(2)
  1.  ; ***** $I & IO MUST BE VALID, CALLER MUST CLOSE OUTPUT DEVICE
  1.  ; IHS/ANMC/LJF 4/30/99 added CWAD display to header line
  1.  ;
  1. START ;
  1.  U IO
  1.  K DIC
  1.  NEW A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
  1.  S APCHOTYP=APCHSTYP
  1.  I $E($G(XQY0),1,2)="SD"!($E($G(XQY0),1,3)="ASD")!($E($G(XQY0),1,3)="BSD") D
  1.  .;is site parameters indicate to do so, switch to diabetes if DM on PL
  1.  .Q:$P($G(^APCHSITE(DUZ(2),0)),U,2)'=1  ;don't switch per site parameters
  1.  .Q:$P($G(^APCHSITE(DUZ(2),0)),U,3)=""  ;no dm type defined
  1.  .Q:'$$PLTAX^APCHSMU(APCHSPAT,"SURVEILLANCE DIABETES")
  1.  .S APCHSTYP=$P(^APCHSITE(DUZ(2),0),U,3)
  1.  S DFN=APCHSPAT
  1.  S APCHSCKP="Q:$D(APCHSQIT)  S APCHSNPG=0 I $Y>(IOSL-3) "
  1.  S APCHSBRK="D BREAK^APCHS"
  1.  I $P(IOST,"-",1)="C" S APCHSCKP=APCHSCKP_"W ""<>"" R X:DTIME S:'$T X=U S:X[U APCHSQIT="""" I '$D(APCHSQIT) "
  1.  S APCHSCKP=APCHSCKP_"W @IOF"_$S($P(IOST,"-",1)="C":",!",1:"")_" D HEADER^APCHS,BREAK^APCHS S APCHSNPG=1"
  1.  X:$D(IO("S")) $S($D(^DD("OS",^DD("OS"),"XY")):"S (IOX,IOY)=0 X ^(""XY"")",1:"W @IOF")
  1.  ;W:$P(IOST,"-",1)="C" @IOF D OUTPUT W:$P(IOST,"-",1)'="C" @IOF ;IHS/CMI/LAB - commented and added line below per G. Shorr
  1.  W:$P(IOST,"-",1)="C"&('$D(APCHSIOF)) @IOF D OUTPUT W:$P(IOST,"-",1)'="C"&('$D(APCHSIOF)) @IOF
  1. KILLS ;
  1.  NEW APCHSTYP,APCHSPAT,APCHSMQ,APCHSMI
  1.  D EN^XBVK("APCH")
  1.  Q
  1. OUTPUT S APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
  1.  S APCHSICF=$S('$D(^APCHSCTL(APCHSTYP,2)):"L",$P(^(2),U,1)]"":$P(^(2),U,1),1:"L")
  1.  S APCHSPG=0
  1.  S Y=DT X ^DD("DD") S APCHSDAT=Y D NOW^%DTC S X=% X ^DD("FUNC",2,1) S APCHSTIM=X
  1.  ;***** CONFIDENTIAL PATIENT INFORMATION --  DATE/TIME **************
  1.  S APCHSHDR="CONFIDENTIAL PATIENT INFORMATION -- "_$$FMTE^XLFDT(DT,5)_$J(APCHSTIM,9)_"  ["_$P(^VA(200,DUZ,0),U,2)_"]" S X="",$P(X,"*",((IOM-6-$L(APCHSHDR))\2)+1)="*" S APCHSHDR=X_" "_APCHSHDR_" "_X
  1.  K APCHSDAT,APCHSTIM
  1.  D HEADER
  1.  K APCHSQIT S APCHSEGN="",APCHSQ="" F  S APCHSEGN=$O(^APCHSCTL(APCHSTYP,1,"B",APCHSEGN)) Q:APCHSEGN=""  S APCHSEGT=$O(^(APCHSEGN,"")) D SEGMNT Q:$D(APCHSQIT)
  1.  ;*** END ** CONFIDENTIAL PATIENT INFORMATION -- DATE/TIME **********
  1.  S APCHSHDR=$E(APCHSHDR,1,3)_" END "_$E(APCHSHDR,8,255) ;IHS/CMI/LAB
  1.  W !,APCHSHDR,!
  1.  S APCHSCKP=$P(APCHSCKP," I '$D(APCHSQIT)",1) ; BE VERY CAREFUL HERE !!!
  1.  I '$D(APCHSQIT) X APCHSCKP
  1.  ;
  1. EXIT ;
  1.  S:$D(ZTQUEUED) ZTREQ="@"
  1.  Q
  1.  ;
  1. SEGMNT ; OUTPUT A SEGMENT TYPE
  1.  S APCHSN=^APCHSCTL(APCHSTYP,1,APCHSEGT,0)
  1.  S APCHSEGC=$P(APCHSN,U,2),APCHSEGH=$P(APCHSN,U,5)
  1.  S APCHSEGP=^APCHSCMP(APCHSEGC,0)
  1.  S APCHSEGC=$P(APCHSEGP,U,2)
  1.  I APCHSEGH="" S APCHSVAR=$P(APCHSEGP,U,4) S:APCHSVAR]"" APCHSEGH=APCHSVAR
  1.  I APCHSEGH="" S APCHSEGH=$P(APCHSEGP,U,1)
  1.  S APCHSVAR=$P(APCHSEGP,U,5) I APCHSVAR]"",$D(^XUSEC(APCHSVAR,DUZ))[0 Q
  1.  S APCHSN=^APCHSCTL(APCHSTYP,1,APCHSEGT,0) S APCHSNDM=$P(APCHSN,U,3),APCHSDLM=$P(APCHSN,U,4) S:APCHSNDM="" APCHSNDM=-1 ;S:APCHSNDM>0 APCHSNDM=APCHSNDM+1
  1.  ;LIMIT OF TIME OR VISITS
  1.  S APCHSDLS=""
  1.  I APCHSDLM?1N.N!(APCHSDLM?1N.N1"D") S APCHSDLS=+APCHSDLM_" day"
  1.  S:APCHSDLM?1N.N1"M" APCHSDLS=+APCHSDLM_" month",APCHSDLM=+APCHSDLM*30
  1.  S:APCHSDLM?1N.N1"Y" APCHSDLS=+APCHSDLM_" year",APCHSDLM=+APCHSDLM*365
  1.  S APCHSDLM=+APCHSDLM
  1.  S:+APCHSDLS>1 APCHSDLS=APCHSDLS_"s"
  1.  S APCHSEGL="" I APCHSNDM>0!(APCHSDLM>0) S APCHSEGL=" (max "_$S(APCHSNDM>0:APCHSNDM_$S(APCHSNDM=1:" visit",1:" visits")_$S(APCHSDLM>0:" or ",1:""),1:"")_$S(APCHSDLM>0:APCHSDLS,1:"")_")"
  1.  K APCHSDLS,APCHSN
  1.  I APCHSDLM'>0 S APCHSDLM=9999999
  1.  E  S X1=DT,X2=-APCHSDLM D C^%DTC S APCHSDLM=9999999-X K X1,X2
  1.  D @($P(APCHSEGC,";",1)_U_$P(APCHSEGC,";",2))
  1.  Q
  1.  ;
  1.  ;******* KETCHUP,LOIS  (CMED SUMMARY)  pg. 1 ********************
  1.  ;S APCHSPG=APCHSPG+1,APCHSHD2=$P(^DPT(APCHSPAT,0),U,1)_"  ("_$P(^APCHSCTL(APCHSTYP,0),U,1)_" SUMMARY)  pg. "_APCHSPG,APCHSP="",$P(APCHSP,"*",((IOM-6-$L(APCHSHD2))\2)+1)="*",APCHSP=APCHSP_" "_APCHSHD2_" "_APCHSP
  1.  S APCHSPG=APCHSPG+1
  1.  ;S APCHSHD2=$P(^DPT(APCHSPAT,0),U)_" #"_$$HRN^AUPNPAT(APCHSPAT,DUZ(2))_"  ("_$P(^APCHSCTL(APCHSTYP,0),U)_" SUMMARY)  pg "_APCHSPG
  1.  S APCHSHD2=$P(^DPT(APCHSPAT,0),U)_" #"_$$HRN^AUPNPAT(APCHSPAT,DUZ(2))_" "_$$CWAD^AUPNLKID(APCHSPAT)_"("_$P(^APCHSCTL(APCHSTYP,0),U)_" SUMMARY)  pg "_APCHSPG  ;IHS/ANMC/LJF 4/30/99
  1.  S APCHSP="",$P(APCHSP,"*",((IOM-6-$L(APCHSHD2))\2)+1)="*",APCHSP=APCHSP_" "_APCHSHD2_" "_APCHSP
  1.  W !,APCHSHDR,!,APCHSP,!
  1.  Q
  1.  ;
  1. BREAK ;ENTRY POINT
  1.  ;APCHSEGH IS THE COMPONENT TYPE FROM ^APCHSCMP, FROM SEGMNT ABOVE
  1.  ;------- MEDICATIONS --------------------
  1.  S APCHSP="",$P(APCHSP,"-",IOM-3-$L(APCHSEGH_APCHSEGL)/2)="",APCHSP=APCHSP_" "_APCHSEGH_APCHSEGL_" "_APCHSP
  1.  I $Y'>(IOSL-5) W !,APCHSP,!! Q
  1.  W !! X APCHSCKP
  1.  Q