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

ACMPROB.m

Go to the documentation of this file. 
  1. ACMPROB ; IHS/TUCSON/TMJ - DISPLAY OF PCC PROBLEM LIST ; [ 07/11/1999  8:59 PM ]
  1.  ;;2.0;ACM CASE MANAGEMENT SYSTEM;**1**;JAN 10, 1996
  1.  ;IHS/CMI/LAB - y2k patch 1
  1.  ;Called from CASE MANAGEMENT SYSTEM to display PCC problems
  1.  ;ACMPTNO must equal the patient DFN
  1.  ;EP;ENTRY POINT
  1.  ;begin Y2K
  1.  ;S ACMTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_$E(Y,2,3)",ACMTTAT="A" ;Y2000
  1.  S ACMTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_(1700+$E(Y,1,3))",ACMTTAT="A" ;Y2000
  1.  ;end Y2K
  1.  D COMMON
  1.  S ACMTTAT="I"
  1.  D COMMON
  1.  K ACMTCVD,ACMTQ,Y
  1.  D PROBX
  1.  Q
  1. COMMON ;
  1.  I '$D(^AUPNPROB("AC",ACMPTNO)) W !!?4,"********** No ",$S(ACMTTAT="A":"  ACTIVE",1:"INACTIVE")," Problems in PCC file for this Patient **********",!?4,"(To update the PCC problem list use PCC encounter form.)",! Q
  1.  K ACMTDFT
  1.  S ACMTNDF=0,ACMTFAC=""
  1.  F ACMTQ=0:0 S ACMTFAC=$O(^AUPNPROB("AA",ACMPTNO,ACMTFAC)) Q:'ACMTFAC  D PROBSCH
  1.  I ACMTNDF=0 W !!?4,"********** No ",$S(ACMTTAT="A":"  ACTIVE",1:"INACTIVE")," Problems in PCC file for this Patient **********",!?4,"(To update the PCC problem list use PCC encounter form.)",! Q
  1.  W !!?4,"****************"_$S(ACMTTAT="A":"    ACTIVE ",1:"  INACTIVE ")_"PCC PROBLEMS AND NOTES  *********************",!?4,"(To update PCC problem list use PCC encounter form.)",!
  1.  S ACMTFPP=""
  1.  F ACMTQ=0:0 S ACMTFPP=$O(ACMTDFT(ACMTFPP)) Q:ACMTFPP=""  S ACMTDFN=ACMTDFT(ACMTFPP) D PROBDSP
  1. PROBX K ACMTDFT,ACMTNDF,ACMTFPP,ACMTFAC,ACMTPLN,ACMTPBN,ACMTDTM,ACMTDTN,ACMTPRB,ACMTTAT,ACMTNFP,ACMTNRQ,ACMTPNM,ACMTDFN,ACMTFCN,ACMTICD,ACMTICL,ACMTILN,ACMTN,ACMTNFL,ACMTNSH,ACMTNAB,ACMTVSC,ACMTITE
  1.  Q
  1. PROBSCH ;
  1.  S ACMTPRB=""
  1.  F ACMTQ=0:0 S ACMTPRB=$O(^AUPNPROB("AA",ACMPTNO,ACMTFAC,ACMTPRB)) Q:ACMTPRB=""  S ACMTDFN=$O(^(ACMTPRB,"")) S:$P(^AUPNPROB(ACMTDFN,0),U,12)=ACMTTAT ACMTNDF=ACMTNDF+1,ACMTDFT(ACMTFAC_ACMTPRB)=ACMTDFN
  1.  Q
  1. PROBDSP ;
  1.  S ACMTN=^AUPNPROB(ACMTDFN,0),ACMTNRQ=$P(ACMTN,U,5)
  1.  D GETNARR
  1.  E  S ACMTNRQ=""
  1.  S ACMTITE=$P(ACMTN,U,6)
  1.  D GETSITE
  1.  S ACMTPNM=$P(ACMTN,U,7),ACMTPNM=ACMTNAB_ACMTPNM,Y=$P(ACMTN,U,3)
  1.  X ACMTCVD
  1.  S ACMTDTM=Y,Y=$P(ACMTN,U,8)
  1.  X ACMTCVD
  1.  S ACMTDTN=Y,ACMTPLN=ACMTPNM_$E("         ",1,12-$L(ACMTPNM))_ACMTDTM
  1.  W ?3,ACMTPLN
  1.  S ACMTICL=24,ACMTILN=58
  1.  D PRTICD,NOTEDSP
  1.  Q
  1. NOTEDSP ; DISPLAY NOTES UNDER PROBLEM
  1.  S ACMTNFP=0
  1.  F ACMTQ=0:0 S ACMTNFP=$O(^AUPNPROB(ACMTDFN,11,ACMTNFP)) Q:'ACMTNFP  D DSPFACN
  1.  Q
  1. DSPFACN ; DISPLAY NOTES FOR SELECTED APSHCFACILITY
  1.  Q:$D(^AUPNPROB(ACMTDFN,11,ACMTNFP,11,0))'=1!($O(^(0))="")
  1.  S ACMTITE=^AUPNPROB(ACMTDFN,11,ACMTNFP,0)
  1.  D GETSITE
  1.  S ACMTFCN=ACMTNAB,ACMTNDF=0
  1.  F ACMTQ=0:0 S ACMTNDF=$O(^AUPNPROB(ACMTDFN,11,ACMTNFP,11,ACMTNDF)) Q:'ACMTNDF  D DSPN ; ACC
  1.  Q
  1. DSPN ; DISPLAY SINGLE NOTE
  1.  S ACMTN=^AUPNPROB(ACMTDFN,11,ACMTNFP,11,ACMTNDF,0) ;/IHS/OHPRD/TMJ 9/20/95
  1.  Q:$P(ACMTN,U,4)="I"
  1.  F ACMTQ=0:0 Q:$E(ACMTFCN)'=" "  S ACMTFCN=$E(ACMTFCN,2,99)
  1.  W ?3,ACMTPNM," (",ACMTFCN,$P(ACMTN,U,1),")",?29,$P(ACMTN,U,3),!
  1.  Q
  1.  ;
  1. PRTICD ;
  1.  S:ACMTNRQ="" ACMTNRQ="<no narrative provided>"
  1.  S ACMTICD="",ACMTTXT=ACMTICD
  1.  D PRTTXT
  1.  Q
  1.  ;
  1. PRTTXT ; GENERALIZED TEXT PRINTER
  1.  S ACMTDLT=1,ACMTILN=80-ACMTICL-1
  1.  F ACMTQ=0:0 S:ACMTNRQ]""&(($L(ACMTNRQ)+$L(ACMTTXT)+2)<255) ACMTTXT=$S(ACMTTXT]"":ACMTTXT_"; ",1:"")_ACMTNRQ,ACMTNRQ="" Q:ACMTTXT=""  D:ACMTQ>15 PAUSE D PRTTXT2
  1.  K ACMTILN,ACMTDLT,ACMTF,ACMTC,ACMTTXT
  1.  Q
  1. PRTTXT2 D GETFRAG
  1.  W ?ACMTICL+5,ACMTF,!
  1.  S ACMTICL=ACMTICL+ACMTDLT,ACMTILN=ACMTILN-ACMTDLT,ACMTDLT=0
  1.  Q
  1. GETFRAG I $L(ACMTTXT)<ACMTILN S ACMTF=ACMTTXT,ACMTTXT="" Q
  1.  F ACMTC=ACMTILN:-1:1 Q:$E(ACMTTXT,ACMTC)=" "
  1.  S ACMTF=$E(ACMTTXT,1,ACMTC-1),ACMTTXT=$E(ACMTTXT,ACMTC+1,255)
  1.  Q
  1.  ;
  1. GETNARR ;
  1.  I ACMTNRQ]"" S ACMTNRQ=$S($D(^AUTNPOV(ACMTNRQ)):$P(^AUTNPOV(ACMTNRQ,0),U,1),1:"***** "_ACMTNRQ_" *****")
  1.  E  S ACMTNRQ=""
  1.  Q
  1.  ;
  1. GETSITE ;
  1.  S:ACMTITE="" ACMTITE="null"
  1.  S %=$S($D(^AUTTLOC(ACMTITE,0)):^(0),1:""),ACMTNFL=$P(%,U,1),ACMTNFL=$S($D(^DIC(4,ACMTITE,0)):$P(^(0),U,1),1:"<"_ACMTITE_">"),ACMTNSH=$P(%,U,2)
  1.  I ACMTNSH="" S ACMTNSH="<"_ACMTITE_">"
  1.  S ACMTNAB=$J($P(%,U,7),4)
  1.  I ACMTNAB="" S ACMTNAB="<"_ACMTITE_">"
  1.  Q
  1. PAUSE ;
  1.  I IOST["C-" S DIR(0)="EOA",DIR("A")="Press <ENTER> to continue..... " D ^DIR K DIR
  1.  Q