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

GMPLUTL1.m

Go to the documentation of this file. 
  1. GMPLUTL1 ; SLC/MKB/KER -- PL Utilities (cont) ;06/08/12  12:14
  1.  ;;2.0;Problem List;**3,8,7,9,26,35,39,36**;Aug 25, 1994;Build 65
  1.  ;
  1.  ; External References
  1.  ;   DBIA   446  ^AUTNPOV(
  1.  ;   DBIA 10082  ^ICD9(
  1.  ;   DBIA  1571  ^LEX(757.01
  1.  ;   DBIA 10040  ^SC(
  1.  ;   DBIA 10060  ^VA(200
  1.  ;   DBIA 10003  ^%DT
  1.  ;   DBIA 10104  $$UP^XLFSTR
  1.  ;
  1.  ; All entry points in this routine expect the
  1.  ; PL("data item") array from routine ^GMPLUTL.
  1.  ;
  1.  ;   Entry     Expected Variable
  1.  ;   Point     From VADPT^GMPLX1
  1.  ;    AO           GMPAGTOR
  1.  ;    IR           GMPION
  1.  ;    EC           GMPGULF
  1.  ;    HNC          GMPHNC
  1.  ;    MST          GMPMST
  1.  ;    CV           GMPCV
  1.  ;    SHD          GMPSHD
  1.  ;
  1.  Q
  1. DIAGNOSI ; ICD Diagnosis Pointer
  1.  S:'$L($G(PL("DIAGNOSIS"))) PL("DIAGNOSIS")=$$NOS^GMPLX
  1.  Q:$P($$CODEC^ICDCODE(+PL("DIAGNOSIS"),$S($$PATCH^XPDUTL("ICD*18.0*57"):80,1:"")),U)'=-1
  1.  S GMPQUIT=1,PLY(0)="Invalid ICD Diagnosis"
  1.  Q
  1.  ;
  1. LEXICON ; Clinical Lexicon Pointer
  1.  S:'$L($G(PL("LEXICON"))) PL("LEXICON")=1
  1.  Q:$D(^LEX(757.01,+PL("LEXICON"),0))
  1.  S GMPQUIT=1,PLY(0)="Invalid Lexicon term"
  1.  Q
  1. DUPLICAT ; Problem Already on the List
  1.  N DUPL
  1.  Q:$P($G(^GMPL(125.99,1,0)),U,6)'=1
  1.  S:'$L($G(PL("DIAGNOSIS"))) PL("DIAGNOSIS")=$$NOS^GMPLX
  1.  I '$D(^AUPNPROB("B",+PL("DIAGNOSIS")))!('$D(^AUPNPROB("AC",GMPDFN))) Q
  1.  F IFN=0:0 S IFN=$O(^AUPNPROB("AC",GMPDFN,IFN)) Q:IFN'>0  D  Q:$D(GMPQUIT)
  1.  . S (DUPL(1),DUPL(2))=0
  1.  . S NODE0=$G(^AUPNPROB(IFN,0)),NODE1=$G(^(1)) Q:$P(NODE1,U,2)="H"
  1.  . I +PL("DIAGNOSIS")=+NODE0 S DUPL(1)=IFN
  1.  . S:PL("NARRATIVE")=$$UP^XLFSTR($P(^AUTNPOV($P(NODE0,U,5),0),U)) DUPL(2)=IFN
  1.  . I DUPL(1)>0&DUPL(2)>0 S GMPQUIT=1,PLY(0)="Duplicate problem"
  1.  Q
  1.  ;
  1. LOCATION ; Hospital Location (Clinic) Pointer
  1.  S:'$D(PL("LOCATION")) PL("LOCATION")="" Q:'$L(PL("LOCATION"))
  1.  I $D(^SC(+PL("LOCATION"),0)) S:$P(^(0),U,3)'="C" PL("LOCATION")="" Q
  1.  S GMPQUIT=1,PLY(0)="Invalid hospital location"
  1.  Q
  1.  ;
  1. PROVIDER ; Responsible Provider
  1.  S:'$D(PL("PROVIDER")) PL("PROVIDER")=""
  1.  Q:'$L(PL("PROVIDER"))  Q:$D(^VA(200,+PL("PROVIDER"),0))
  1.  S GMPQUIT=1,PLY(0)="Invalid provider"
  1.  Q
  1.  ;
  1. STATUS ; Problem Status
  1.  S:$G(PL("STATUS"))="" PL("STATUS")="A"
  1.  I "^A^I^a^i^"[(U_PL("STATUS")_U) S PL("STATUS")=$$UP^XLFSTR(PL("STATUS")) Q
  1.  S GMPQUIT=1,PLY(0)="Invalid problem status"
  1.  Q
  1.  ;
  1. ONSET ; Date of Onset
  1.  N %DT,Y,X
  1.  S:'$D(PL("ONSET")) PL("ONSET")="" Q:'$L(PL("ONSET"))
  1.  S %DT="P",%DT(0)="-NOW",X=PL("ONSET") D ^%DT
  1.  I Y>0 S PL("ONSET")=Y Q
  1.  S GMPQUIT=1,PLY(0)="Invalid Date of Onset"
  1.  Q
  1.  ;
  1. RESOLVED ; Date Resolved (Requires STATUS, ONSET)
  1.  N %DT,Y,X
  1.  S:'$D(PL("RESOLVED")) PL("RESOLVED")="" Q:'$L(PL("RESOLVED"))
  1.  S %DT="P",%DT(0)="-NOW",X=PL("RESOLVED") D ^%DT
  1.  I Y'>0 S GMPQUIT=1,PLY(0)="Invalid Date Resolved" Q
  1.  I PL("STATUS")="A" S GMPQUIT=1,PLY(0)="Active problems cannot have a Date Resolved" Q
  1.  I Y<PL("ONSET") S GMPQUIT=1,PLY(0)="Date Resolved cannot be prior to Date of Onset" Q
  1.  S PL("RESOLVED")=Y
  1.  Q
  1.  ;
  1. RECORDED ; Date Recorded (Requires ONSET)
  1.  N %DT,Y,X
  1.  S:'$D(PL("RECORDED")) PL("RECORDED")="" Q:'$L(PL("RECORDED"))
  1.  S %DT="P",%DT(0)="-NOW",X=PL("RECORDED") D ^%DT
  1.  I Y'>0 S GMPQUIT=1,PLY(0)="Invalid Date Recorded" Q
  1.  I PL("RECORDED")<PL("ONSET") S GMPQUIT=1,PLY(0)="Date Recorded cannot be prior to Date of Onset" Q
  1.  S PL("RECORDED")=Y
  1.  Q
  1.  ;
  1. SC ; SC condition flag
  1.  S:'$D(PL("SC")) PL("SC")=""
  1.  I "^^1^0^"'[(U_PL("SC")_U) S GMPQUIT=1,PLY(0)="Invalid SC flag" Q
  1.  I 'GMPSC,+PL("SC") S GMPQUIT=1,PLY(0)="Invalid SC flag"
  1.  Q
  1.  ;
  1. AO ; AO exposure flag (Requires GMPAGTOR)
  1.  S:'$D(PL("AO")) PL("AO")=""
  1.  I "^^1^0^"'[(U_PL("AO")_U) S GMPQUIT=1,PLY(0)="Invalid AO flag" Q
  1.  I 'GMPAGTOR,+PL("AO") S GMPQUIT=1,PLY(0)="Invalid AO flag"
  1.  Q
  1.  ;
  1. IR ; IR exposure flag (Requires GMPION)
  1.  S:'$D(PL("IR")) PL("IR")=""
  1.  I "^^1^0^"'[(U_PL("IR")_U) S GMPQUIT=1,PLY(0)="Invalid IR flag" Q
  1.  I 'GMPION,+PL("IR") S GMPQUIT=1,PLY(0)="Invalid IR flag"
  1.  Q
  1.  ;
  1. EC ; EC exposure flag (Requires GMPGULF)
  1.  S:'$D(PL("EC")) PL("EC")=""
  1.  I "^^1^0^"'[(U_PL("EC")_U) S GMPQUIT=1,PLY(0)="Invalid EC flag" Q
  1.  I 'GMPGULF,+PL("EC") S GMPQUIT=1,PLY(0)="Invalid EC flag"
  1.  Q
  1. HNC ; HNC/NTR exposure flag (Requires GMPHNC)
  1.  S:'$D(PL("HNC")) PL("HNC")=""
  1.  I "^^1^0^"'[(U_PL("HNC")_U) S GMPQUIT=1,PLY(0)="Invalid HNC flag" Q
  1.  I 'GMPHNC,+PL("HNC") S GMPQUIT=1,PLY(0)="Invalid HNC flag"
  1.  Q
  1. MST ; MST exposure flag (Requires GMPMST)
  1.  S:'$D(PL("MST")) PL("MST")=""
  1.  I "^^1^0^"'[(U_PL("MST")_U) S GMPQUIT=1,PLY(0)="Invalid MST flag" Q
  1.  I 'GMPMST,+PL("MST") S GMPQUIT=1,PLY(0)="Invalid MST flag"
  1.  Q
  1. CV ; CV exposure flag (Requires GMPCV)
  1.  S:'$D(PL("CV")) PL("CV")=""
  1.  I "^^1^0^"'[(U_PL("CV")_U) S GMPQUIT=1,PLY(0)="Invalid CV flag" Q
  1.  I 'GMPCV,+PL("CV") S GMPQUIT=1,PLY(0)="Invalid CV flag"
  1.  Q
  1. SHD ; SHD exposure flag (Requires GMPSHD)
  1.  S:'$D(PL("SHD")) PL("SHD")=""
  1.  I "^^1^0^"'[(U_PL("SHD")_U) S GMPQUIT=1,PLY(0)="Invalid SHD flag" Q
  1.  I 'GMPSHD,+PL("SHD") S GMPQUIT=1,PLY(0)="Invalid SHD flag"
  1.  Q
  1. CENTER(X) ; Center X
  1.  N SP
  1.  S $P(SP," ",((IOM-$L(X))\2))=""
  1.  Q $G(SP)_X
  1. READ(TYPE,PROMPT,DEFAULT,HELP,SCREEN) ; Calls reader, returns response
  1.  N DIR,X,Y
  1.  S DIR(0)=TYPE
  1.  I $D(SCREEN) S DIR("S")=SCREEN
  1.  I $G(PROMPT)]"" S DIR("A")=PROMPT
  1.  I $G(DEFAULT)]"" S DIR("B")=DEFAULT
  1.  I $D(HELP) S DIR("?")=HELP
  1.  D ^DIR
  1.  I $G(X)="@" S Y="@" G READX
  1.  I Y]"",($L($G(Y),U)'=2) S Y=Y_U_$G(Y(0),Y)
  1. READX Q Y
  1. EDATE(PRMPT,STATUS,DFLT) ; Get early date
  1.  N X,Y,GMPLPRMT,GMPLDFLT
  1.  I $G(STATUS)=4 S Y=1 Q Y
  1.  S GMPLPRMT=" Start "_$S($L($G(PRMPT)):PRMPT_" ",1:"")_"Date [Time]: "
  1.  S GMPLDFLT=$S($L($G(DFLT)):DFLT,1:"T-30")
  1.  S Y=$$READ("DOA^::AET",GMPLPRMT,GMPLDFLT)
  1.  Q Y
  1. LDATE(PRMPT,STATUS,DFLT) ; Get late date
  1.  N X,Y,GMPLPRMT,GMPLDFLT
  1.  I $G(STATUS)=4 S Y=9999999 Q Y
  1.  S GMPLPRMT="Ending "_$S($L($G(PRMPT)):PRMPT_" ",1:"")_"Date [Time]: "
  1.  S GMPLDFLT=$S($L($G(DFLT)):DFLT,1:"NOW")
  1.  S Y=$$READ("DOA^::AET",GMPLPRMT,GMPLDFLT)
  1.  Q Y
  1. STOP(PROMPT,SCROLL) ; Call DIR at bottom of screen
  1.  N DIR,X,Y
  1.  I $E(IOST)'="C" S Y="" G STOPX
  1.  I +$G(SCROLL),(IOSL>($Y+5)) F  W ! Q:IOSL<($Y+6)
  1.  S DIR(0)="FO^1:1",DIR("A")=$S($G(PROMPT)]"":PROMPT,1:"Press RETURN to continue or '^' to exit")
  1.  S DIR("?")="Enter '^' to quit present action or '^^' to quit to menu"
  1.  D ^DIR I $D(DIRUT),(Y="") K DIRUT
  1.  S Y=$S(Y="^":0,Y="^^":0,$D(DTOUT):"",Y="":1,1:1_U_Y)
  1. STOPX Q Y
  1. DATE(X,FMT) ; Call with X=2910419.01 and FMT=Return Format of date ("MM/DD")
  1.  N AMTH,MM,CC,DD,YY,GMPLI,GMPLTMP
  1.  I +X'>0 S $P(GMPLTMP," ",$L($G(FMT))+1)="",FMT=GMPLTMP G QDATE
  1.  I $S('$D(FMT):1,'$L(FMT):1,1:0) S FMT="MM/DD/YY"
  1.  S MM=$E(X,4,5),DD=$E(X,6,7),YY=$E(X,2,3),CC=17+$E(X)
  1.  S:FMT["AMTH" AMTH=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+MM)
  1.  F GMPLI="AMTH","MM","DD","CC","YY" S:FMT[GMPLI FMT=$P(FMT,GMPLI)_@GMPLI_$P(FMT,GMPLI,2)
  1.  I FMT["HR" S FMT=$$TIME(X,FMT)
  1. QDATE Q FMT
  1. TIME(X,FMT) ; Recieves X as 2910419.01 and FMT=Return Format of time (HH:MM:SS).
  1.  N HR,MIN,SEC,GMPLI
  1.  I $S('$D(FMT):1,'$L(FMT):1,1:0) S FMT="HR:MIN"
  1.  S X=$P(X,".",2),HR=$E(X,1,2)_$E("00",0,2-$L($E(X,1,2))),MIN=$E(X,3,4)_$E("00",0,2-$L($E(X,3,4))),SEC=$E(X,5,6)_$E("00",0,2-$L($E(X,5,6)))
  1.  F GMPLI="HR","MIN","SEC" S:FMT[GMPLI FMT=$P(FMT,GMPLI)_@GMPLI_$P(FMT,GMPLI,2)
  1.  Q FMT
  1. NAME(X,FMT) ; Call with X="LAST,FIRST MI", FMT=Return Format ("LAST, FI")
  1.  N GMPLLAST,GMPLLI,GMPFIRST,GMPLFI,GMPLMI,GMPLI
  1.  I X']"" S FMT="" G NAMEX
  1.  I $S('$D(FMT):1,'$L(FMT):1,1:0) S FMT="LAST,FIRST"
  1.  S FMT=$$LOW^XLFSTR(FMT)
  1.  S GMPLLAST=$P(X,","),GMPLLI=$E(GMPLLAST),GMPFIRST=$P(X,",",2)
  1.  S GMPLFI=$E(GMPFIRST)
  1.  S GMPLMI=$S($P(GMPFIRST," ",2)'="NMI":$E($P(GMPFIRST," ",2)),1:"")
  1.  S GMPFIRST=$P(GMPFIRST," ")
  1.  F GMPLI="last","li","first","fi","mi" I FMT[GMPLI S FMT=$P(FMT,GMPLI)_@("GMPL"_$$UP^XLFSTR(GMPLI))_$P(FMT,GMPLI,2)
  1. NAMEX Q FMT
  1. TITLE(X) ; Pads titles
  1.  ; Recieves:    X=title to be padded
  1.  N I,TITLE
  1.  S TITLE="" F I=1:1:$L(X) S TITLE=TITLE_" "_$E(X,I)
  1.  Q TITLE
  1. JUSTIFY(X,JUST) ; Justifies Text
  1.  ; Receives:    X=text to be justified
  1.  ;           JUST="L" --> left, "C" --> center, "R" --> right,
  1.  ;                "J" --> justified to WIDTH
  1.  ;           WIDTH=justification width (when JUST="j"
  1.  I "Cc"[JUST W ?((80-$L(X))/2),X
  1.  I "Ll"[JUST W X,!!
  1.  I "Rr"[JUST W ?(80-$L(X)),X
  1.  Q