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

GMPLRPTR.m

Go to the documentation of this file. 
  1. GMPLRPTR ; SLC/MKB/AJB -- Problem List Report of Removed Problems ;4/10/03
  1.  ;;2.0;Problem List;**28**;Aug 25, 1994
  1. EN ; -- main entry point
  1.  S GMPDFN=$$PAT^GMPLX1 Q:+GMPDFN'>0
  1.  D WAIT^DICD,GETLIST
  1.  I GMPLIST(0)'>0 W $C(7),!!?10,"No 'removed' problems found for this patient.",! Q
  1.  D DISPLAY,REPLACE
  1.  K GMPDFN,GMPLIST
  1.  Q
  1.  ;
  1. GETLIST ; -- build GMPLIST() of removed problems
  1.  N IFN,CNT,NODE S CNT=0
  1.  F IFN=0:0 S IFN=$O(^AUPNPROB("AC",+GMPDFN,IFN)) Q:IFN'>0  D
  1.  . S NODE=$G(^AUPNPROB(IFN,1)) Q:$P(NODE,U,2)'="H"
  1.  . S CNT=CNT+1,GMPLIST(CNT)=IFN W "."
  1.  S GMPLIST(0)=CNT
  1.  Q
  1.  ;
  1. DISPLAY ; -- show list on screen
  1.  N PROBLEM,DATE,USER,NUM,PROV,IDT,AIFN,NODE,DONE,GMPQUIT D HDR
  1.  F NUM=0:0 S NUM=$O(GMPLIST(NUM)) Q:NUM'>0  D  Q:$D(GMPQUIT)
  1.  . S IFN=GMPLIST(NUM) Q:'IFN
  1.  . S PROBLEM=$$PROBTEXT^GMPLX(IFN),(DATE,PROV)="" K DONE
  1.  . ; added for Code Set Versioning (CSV)
  1.  . I '$$CODESTS^GMPLX(IFN,DT) S PROBLEM="#"_PROBLEM
  1.  . F IDT=0:0 S IDT=$O(^GMPL(125.8,"AD",IFN,IDT)) Q:IDT'>0  D  Q:$D(DONE)
  1.  . . F AIFN=0:0 S AIFN=$O(^GMPL(125.8,"AD",IFN,IDT,AIFN)) Q:AIFN'>0  D  Q:$D(DONE)
  1.  . . . S NODE=$G(^GMPL(125.8,AIFN,0)) Q:$P(NODE,U,2)'=1.02
  1.  . . . I $P(NODE,U,6)="H" S DATE=9999999-IDT,PROV=$P(NODE,U,8),DONE=1
  1.  . I $Y>(IOSL-4) S:'$$CONTINUE GMPQUIT=1 Q:$D(GMPQUIT)  D HDR
  1.  . ; added for Code Set Versioning
  1.  . N GMPLBUF S GMPLBUF=$S(PROBLEM["#":3,1:4)
  1.  . W !,NUM,?GMPLBUF,PROBLEM,?51,$$EXTDT^GMPLX(DATE),?60,$$NAME^GMPLX1(PROV)
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  W @IOF,"REMOVED PROBLEMS FOR "_$P(GMPDFN,U,2)_" ("_$P(GMPDFN,U,3)_"):"
  1.  W !!,"    Problem",?51,"Removed  By Whom",!,$$REPEAT^XLFSTR("-",79)
  1.  Q
  1.  ;
  1. CONTINUE() ; -- end of page prompt
  1.  N DIR,X,Y
  1.  S DIR(0)="E",DIR("A")="Press <return> to continue or ^ to exit ..."
  1.  D ^DIR
  1.  Q +Y
  1.  ;
  1. REPLACE ; -- replace problem on patient's list
  1.  N GMPLSEL,GMPLNO,NUM,CHNGE,NOW,DA,DR,DIE W !!
  1.  S GMPLSEL=$$SEL Q:GMPLSEL="^"  Q:'$$SURE
  1.  W !!,"Replacing problem(s) on patient's list ..."
  1.  S GMPLNO=$L(GMPLSEL,","),NOW=$$HTFM^XLFDT($H)
  1.  F I=1:1:GMPLNO S NUM=$P(GMPLSEL,",",I) I NUM D
  1.  . ; added for Code Set Versioning (CSV)
  1.  . I '$$CODESTS^GMPLX(GMPLIST(NUM),DT) W !!,$$PROBTEXT^GMPLX(GMPLIST(NUM)),!,"has an inactive ICD9 code and will not be replaced." Q
  1.  . S DA=GMPLIST(NUM),DR="1.02////P",DIE="^AUPNPROB(" D ^DIE
  1.  . S CHNGE=DA_"^1.02^"_NOW_U_DUZ_"^H^P^Replaced^"_DUZ
  1.  . D AUDIT^GMPLX(CHNGE,""),DTMOD^GMPLX(DA)
  1.  . W !,"  "_$$PROBTEXT^GMPLX(DA)
  1.  D
  1.  . N DIR S DIR(0)="E" W ! D ^DIR
  1.  Q
  1.  ;
  1. SEL() ; -- select problem(s)
  1.  N DIR,X,Y,MAX
  1.  S MAX=+GMPLIST(0) I MAX'>0 Q "^"
  1.  S DIR(0)="LAO^1:"_MAX,DIR("A")="Select the problem(s) you wish to replace on this patient's list: "
  1.  S DIR("?",1)="Enter the problems you wish to add back on this patient's problem list,",DIR("?")="as a range or list of numbers."
  1.  D ^DIR I $D(DTOUT)!(X="") S Y="^"
  1.  Q Y
  1.  ;
  1. SURE() ; -- are you sure you want to do this?
  1.  N DIR,X,Y
  1.  S DIR(0)="Y",DIR("A")="Are you sure you want to do this",DIR("B")="NO"
  1.  S DIR("?",1)="Enter YES if you are ready to have the selected problems put back on this",DIR("?")="patient's problem list; press <return> to exit without further action."
  1.  W $C(7) D ^DIR
  1.  Q +Y