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