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

APCHS.m

Go to the documentation of this file. 
  1. APCHS ; IHS/CMI/LAB - PCC HEALTH SUMMARY ;
  1.  ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1.  ;fixed CMS display
  1.  ;
  1. VERSION ;;2.0
  1.  ;
  1.  W !!,"* * *  H E A L T H  S U M M A R Y  P R O G R A M  (",$P($T(VERSION),";",3),")  * * *",!!
  1.  S ^DISV($I,"^%ZIS(1,")=$O(^%ZIS(1,"C",$I,"")) ; SET DEFAULT OUTPUT DEVICE
  1.  ;
  1. SELTYP K DIC S DIC=9001015,DIC("A")="Select health summary type: ",DIC(0)="AEQM"
  1.  S X="" I DUZ(2),$D(^APCCCTRL(DUZ(2),0))#2 S X=$P(^(0),U,3)
  1.  I $D(^DISV(DUZ,"^APCHSCTL(")) S Y=^("^APCHSCTL(") I $D(^APCHSCTL(Y,0)) S X=$P(^(0),U,1)
  1.  S:X="" X="ADULT REGULAR"
  1.  S DIC("B")=X
  1.  D ^DIC K DIC I Y>0 S APCHSTYP=+Y D SELPT W ! G SELTYP
  1.  G END
  1. SELPT ;PEP-select patients
  1.  K DIC S DIC=9000001,DIC("A")="Select patient: ",DIC(0)="AEQM" D ^DIC K DIC I Y>0 S APCHSPAT=+Y W:$D(^AUPNPAT(APCHSPAT,41,DUZ(2),0)) !,"Patient's chart number is ",$P(^(0),U,2),! D HSOUT G SELPT
  1.  ;
  1. END ;
  1.  K X,Y,POP,DIR,DIRUT,DUOUT
  1.  D EOJ
  1.  D KILL^AUPNPAT
  1.  K DIC,DA
  1.  Q
  1.  ;
  1. HSOUT ; OUTPUT SUMMARY, WITH DEVICE CONTROL
  1.  K ZTSK
  1.  K IOP,%ZIS S %ZIS="PQM" D ^%ZIS I POP S IO=IO(0) Q
  1.  G:$D(IO("Q")) QUE
  1. NOQUE S ^DISV($I,"^%ZIS(1,")=$O(^%ZIS(1,"C",IO,""))
  1.  D EN
  1.  D ^%ZISC
  1.  Q
  1. QUE K ZTSAVE F APCHSP="APCHSPAT","APCHSTYP" S ZTSAVE(APCHSP)=""
  1.  S ZTRTN="EN^APCHS",ZTDESC="HEALTH SUMMARY",ZTIO=ION,ZTDTH=DT
  1.  D ^%ZTLOAD
  1.  D HOME^%ZIS
  1.  K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK,APCHSP
  1.  Q
  1.  ;
  1.  ; SPECIAL ENTRY POINTS TO HIDE APCHS-APCHS0 SPLIT
  1.  ;
  1. EN ;PEP - PUBLISHED ENTRY POINT - PRINT SUMMARY FOR PATIENT
  1.  G ^APCHS0 ; TRANSFER TO CONTINUATION ROUTINE
  1.  ;
  1.  ; THE FOLLOWING LABELS BRANCH TO CONTINUATION ROUTINE TO PRESERVE
  1.  ; EXISTING ENTRY POINTS USED INTERNALLY BY THE PACKAGE
  1.  ;
  1. BREAK ;ENTRY POINT
  1.  G BREAK^APCHS0
  1.  G HEADER^APCHS0
  1. ENREG ;EP - entry point to display CMS register(s) patient is on, then
  1.  ; ask for summary type
  1.  W !!,"* * *  H E A L T H  S U M M A R Y  P R O G R A M  (",$P($T(VERSION),";",3),")  * * *",!!
  1.  S ^DISV($I,"^%ZIS(1,")=$O(^%ZIS(1,"C",$I,"")) ; SET DEFAULT OUTPUT DEVICE
  1.  ;
  1. GETPT K DIC S DIC=9000001,DIC("A")="Select patient: ",DIC(0)="AEQM" D ^DIC I Y>0 S APCHSPAT=+Y W:$D(^AUPNPAT(APCHSPAT,41,DUZ(2),0)) !,"Patient's chart number is ",$P(^(0),U,2),! D DSPCMSRG,GETTYP G GETPT
  1.  I $D(DUOUT)!($D(DTOUT)) G DONE
  1. DONE K APCHSTYP,APCHSPAT,POP,X,Y
  1.  D EOJ
  1.  K AUPNPAT,AUPNDOB,AUPNDOD,AUPNSEX
  1.  K DIC
  1.  Q
  1. DSPCMSRG ; EP - display membership in CMS register
  1.  Q:'$D(^ACM(41,"D",APCHSPAT))
  1.  S APCHSJ=1
  1.  F APCHSI=0:0 S APCHSI=$O(^ACM(41,"AC",APCHSPAT,APCHSI)) Q:'APCHSI  I $P(^ACM(41.1,APCHSI,0),U,7) W:APCHSJ "ON CMS REGISTER(S): " D
  1.  .S APCHSJ=0 W ?21,$P(^ACM(41.1,APCHSI,0),U)
  1.  .S APCHSK=^ACM(41,"AC",APCHSPAT,APCHSI) W "  Status: ",$$VAL^XBDIQ1(9002241,APCHSK,1),! ;IHS/CMI/LAB - display was not consistent with CMS
  1.  Q
  1. GETTYP ; EP - get health summary TYPE
  1.  K DIC S DIC=9001015,DIC("A")="Select health summary type: ",DIC(0)="AEQM"
  1.  S X="" I DUZ(2),$D(^APCCCTRL(DUZ(2),0))#2 S X=$P(^(0),U,3)
  1.  I $D(^DISV(DUZ,"^APCHSCTL(")) S Y=^("^APCHSCTL(") I $D(^APCHSCTL(Y,0)) S X=$P(^(0),U,1)
  1.  S:X="" X="ADULT REGULAR"
  1.  S DIC("B")=X
  1.  D ^DIC I Y>0 S APCHSTYP=+Y
  1.  Q:$D(DUOUT)
  1.  Q:$D(APCHSBRW)
  1.  D HSOUT
  1.  Q
  1. EN1 ;PEP ;IHS/CMI/LAB - added per G. Shorr
  1.  N APCHSIOF
  1.  S APCHSIOF=1
  1.  G ^APCHS0
  1.  ;
  1. EOJ ;PEP - end of job clean up can be called by other applications that call the Health Summary
  1.  D EN^XBVK("APCH")
  1.  Q