GMTSGAF ; SLC/KER - MH Gbl Assessment Funct (GAF) ; 6/20/05 1:44pm
;;2.7;Health Summary;**35,44,49,74**;Oct 20, 1995
;
; External References
; DBIA 10035 ^DPT(
; DBIA 10003 ^%DT
; DBIA 10088 DEM^VADPT
; DBIA 10103 $$FMADD^XLFDT
; DBIA 10103 $$FMTE^XLFDT
; DBIA 10103 $$NOW^XLFDT
; DBIA 2896 GAFHX^YSGAFAPI
;
Q
EN ; Global Assessment Functioning Score
N MAX S MAX=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:9999999)
S:+($G(GMTSBEG))'>2700101 GMTSBEG=$$FMADD^XLFDT($P($$NOW^XLFDT,".",1),-1095,0,0,1),GMTSEND=$$FMADD^XLFDT($P($$NOW^XLFDT,".",1),1,0,0,1),GMTS2=9999999-GMTSBEG,GMTS1=9999999-GMTSEND
S:'$L($P(GMTSBEG,".",2)) GMTSBEG=$$FMADD^XLFDT(GMTSBEG,0,0,0,1)
S:+($G(GMTSEND))'>2700101!(+($G(GMTSEND))>+($$FMADD^XLFDT($P($$NOW^XLFDT,".",1),+1,0,0,2))) GMTSEND=$$FMADD^XLFDT($P($$NOW^XLFDT,".",1),1,0,0,1),GMTS1=9999999-GMTSEND
S:'$L($P(GMTSEND,".",2)) GMTSEND=$$FMADD^XLFDT(GMTSEND,0,0,0,1)
S:+($G(GMTSEND))>0&(+($G(GMTS1))=0) GMTS1=9999999-GMTSEND S:+($G(GMTSBEG))>0&(+($G(GMTS2))=0) GMTS2=9999999-GMTSBEG
S GMTSLO=+($G(GMTSLO)) S:GMTSLO=0 GMTSLO=3 S GMTSLPG=+($G(GMTSLPG)),GMTSDTM=$G(GMTSDTM) S:'$L(GMTSDTM) GMTSDTM=$$DTM
S:'$D(GMTSTITL)!('$L($G(GMTSTITL))) GMTSTITL="GLOBAL ASSESSMENT FUNCTIONING"
S DFN=+($G(DFN)) Q:'$L($P($G(^DPT(DFN,0)),"^",1))
N %,%DT,%H,%I,%T,%X,I,N,VA,VADM,VAERR,X,Y,YS,YSGAF
N GMTSBAR,GMTSCNT,GMTSCOM,GMTSCORE,GMTSCS,GMTSCW,GMTSDATE,GMTSDT
N GMTSGAF,GMTSGAF1,GMTSGAF2,GMTSGAF3,GMTSGAFN,GMTSI,GMTSJ,GMTSLEN,GMTSPROV,GMTSRV
S GMTSGAF1=$$EXT(+($G(GMTS1))),GMTSGAF2=$$ITM(+($G(GMTS2))),GMTSGAF3=$$TOM
S GMTSGAFN=+($G(MAX)) S:GMTSGAFN=0 GMTSGAFN=10
S GMTSCW(0)=+($G(IOM)) S:GMTSCW(0)=0 GMTSCW(0)=80
S GMTSCW(1)=5,GMTSCW(2)=10,GMTSCW(3)=20,GMTSCW(4)=GMTSCW(0)-(GMTSCW(1)+GMTSCW(2)+GMTSCW(3)+8)
S GMTSCW("L")=(GMTSCW(1)+GMTSCW(2)+GMTSCW(3)+GMTSCW(4)+6)
S GMTSCS(1)=1,GMTSCS(2)=GMTSCS(1)+GMTSCW(1)+2,GMTSCS(3)=GMTSCS(2)+GMTSCW(2)+2,GMTSCS(4)=GMTSCS(3)+GMTSCW(3)+2
S YS("DFN")=DFN,YS("BEGIN")=$S($L(GMTSGAF2):GMTSGAF2,1:GMTSGAF3)
S YS("END")=$S($L(GMTSGAF1):GMTSGAF1,1:"01/01/1970"),YS("LIMIT")=GMTSGAFN
D GET Q:'$D(^TMP($J,"GMTSGAF",DFN)) D OUT Q
OUT ; Output
N GMTSI,GMTSJ,GMTSCORE,GMTSDATE,GMTSPROV,GMTSCOM S DFN=+($G(DFN)) Q:DFN=0 D HDR S GMTSI=0 F S GMTSI=$O(^TMP($J,"GMTSGAF",DFN,GMTSI)) Q:+GMTSI=0 D
. S GMTSJ=$G(^TMP($J,"GMTSGAF",DFN,GMTSI))
. S GMTSCORE=$P(GMTSJ,"^",1),GMTSDATE=$P(GMTSJ,"^",2),GMTSPROV=$P(GMTSJ,"^",3),GMTSCOM=$P(GMTSJ,"^",4) S:GMTSCORE=""&(GMTSDATE["----")&($L(GMTSCOM)) GMTSCORE=">>" D LINE
K ^TMP($J,"GMTSGAF",DFN) Q
LINE ; Output One Line
D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG=1 HDR W ?GMTSCS(1),$J($E(GMTSCORE,1,3),3),?GMTSCS(2),GMTSDATE,?GMTSCS(3),$E(GMTSPROV,1,GMTSCW(3)),?GMTSCS(4),GMTSCOM,! Q
HDR ; Header
N GMTSI S GMTSI="",$P(GMTSI,"-",+($G(GMTSCW("L"))))="-"
D CKP^GMTSUP Q:$D(GMTSQIT) G:GMTSNPG=1 HDR W ?GMTSCS(1)," GAF ",?GMTSCS(2),"Date",!
D CKP^GMTSUP Q:$D(GMTSQIT) G:GMTSNPG=1 HDR W ?GMTSCS(1),"Score",?GMTSCS(2),"Determined",?GMTSCS(3),"Determined by",?GMTSCS(4),"Graph/Comment",!
D CKP^GMTSUP Q:$D(GMTSQIT) G:GMTSNPG=1 HDR W ?GMTSCS(1),GMTSI,!
Q
GET ; Get and Format Data
N %DT,X,Y,GMTSGPH,GMTSCORE,GMTSDT,GMTSDATE,GMTSPROV,GMTSCOM S DFN=+($G(DFN)),GMTSGPH=0 K ^TMP($J,"GMTSGAF",DFN),YSGAF D GAFHX^YSGAFAPI(.YSGAF,.YS),SPC
I +($P($G(YSGAF("DEC")),".",1))>0 D
. S GMTSDT=+($P($G(YSGAF("DEC")),".",1)),GMTSCOM="Deceased ("_$$FMTE^XLFDT(GMTSDT,"5ZD")_")" D SD(GMTSDT,DFN,"","","",GMTSCOM)
I +($P($G(YSGAF("DUE")),".",1))>0 D
. S GMTSDT=+($P($G(YSGAF("DUE")),".",1)) Q:GMTSDT>$$TOD S GMTSCOM="Due since "_$$FMTE^XLFDT(GMTSDT,"5ZD") D SD(GMTSDT,DFN,"","","",GMTSCOM)
N I S I=1 F S I=$O(YSGAF(I)) Q:+I=0 D
. S GMTSDT=$P(YSGAF(I),"^",1),GMTSDATE=$P(GMTSDT,".",1),GMTSDATE=$$FMTE^XLFDT(GMTSDATE,"5ZD")
. Q:+($G(YSGAF("DEC")))>0&(+GMTSDATE>+($G(YSGAF("DEC"))))
. S GMTSCORE=$P(YSGAF(I),"^",5),GMTSPROV=$P(YSGAF(I),"^",7)
. S GMTSCOM=+($P($G(YSGAF("ERR",I)),".",1)) S:+GMTSCOM=0 GMTSCOM=""
. S:+GMTSCOM>0 GMTSCOM="Entered in error ("_$$FMTE^XLFDT(GMTSCOM,"5ZD")_")"
. S:GMTSCOM="" GMTSCOM=$$B(GMTSCORE,31)
. D:'$D(YSGAF("ERR",I)) SD(GMTSDT,DFN,GMTSCORE,GMTSDATE,GMTSPROV,GMTSCOM)
Q
SPC ; Get Special Case (Deceased, Due, Entered-in-Error)
N GMTSI S YSGAF("P")=$P($G(^DPT(+($G(DFN)),0)),"^",1)
S GMTSI=$$DEC(+($G(DFN))) S:+GMTSI>0 YSGAF("DEC")=GMTSI I +GMTSI=0 S GMTSI=$$DUE S:+GMTSI>0 YSGAF("DUE")=GMTSI
K:+($G(YSGAF("DEC")))>0 YSGAF("DUE") S GMTSI=$$ERR S:+GMTSI>0 YSGAF("ERR")=GMTSI
Q
SD(GMTSI,DFN,GMTSCORE,GMTSDATE,GMTSPROV,GMTSCOM) ; Save Data
N GMTSIG S (GMTSCORE,GMTSIG)=$G(GMTSCORE),GMTSCORE=$$GAF(GMTSCORE),DFN=+($G(DFN))
S GMTSIG=100-(+($G(GMTSIG)))
S GMTSI=+($G(GMTSI)),GMTSI=9999999.999999-GMTSI
S GMTSPROV=$G(GMTSPROV),GMTSDATE=$G(GMTSDATE)
S GMTSIG=GMTSI_GMTSIG_GMTSPROV_GMTSDATE
S:GMTSDATE="" GMTSDATE="--/--/----"
S ^TMP($J,"GMTSGAF",DFN,GMTSIG)=GMTSCORE_"^"_GMTSDATE_"^"_GMTSPROV_"^"_$G(GMTSCOM)
Q
ERR(X) ; Entered in Error
N GMTSCNT,GMTSI,GMTSGAF,GMTSJ,GMTSDATE S (GMTSCNT,GMTSI)=0,GMTSDATE="" F S GMTSI=$O(YSGAF(GMTSI)) Q:+GMTSI=0 D
. S GMTSGAF=$P(YSGAF(GMTSI),"^",8) Q:GMTSGAF'["entered in error"
. S YSGAF("ERR")="" F GMTSJ=1:1:$L(GMTSGAF," ") D
.. S:$P(GMTSGAF," ",GMTSJ)["@"&(GMTSJ>2) GMTSDATE=$P(GMTSGAF," ",GMTSJ-1,GMTSJ) S:$L(GMTSDATE) GMTSDATE=$$ETF(GMTSDATE)
. S:$L(GMTSDATE) YSGAF("ERR",GMTSI)=GMTSDATE,GMTSCNT=GMTSCNT+1
S X=GMTSCNT Q X
DUE(X) ; GAF Score Due Date
S:'$D(YSGAF(2)) YSGAF(1)="[NO DATA]" N GMTSI,GMTSJ,GMTSDATE S (GMTSI,GMTSJ,GMTSDATE)=0
F S GMTSI=$O(YSGAF(GMTSI)) Q:+GMTSI=0 S GMTSJ=$P(YSGAF(GMTSI),"^",1) S:GMTSJ>GMTSDATE GMTSDATE=GMTSJ
S GMTSDATE=$S(GMTSDATE>0:$$FMADD^XLFDT(GMTSDATE,90,0,0,0),1:"") S X=GMTSDATE Q X
ITM(X) ; convert inverse internal date to internal date to external date
N SAVX ; temp scratch variable to hold value of X
S X=+($G(X)),X=9999999-X ; produce an internal date
S SAVX=X
S X=$$FMTE^XLFDT(X,"5ZD") D ^%DT I Y=-1 D ; if not valid date, default to 3 years ago
. S X1=$$NOW^XLFDT,X2=-1095 D C^%DTC S SAVX=X
S X=SAVX
S X=$$FMTE^XLFDT(X,"5ZD") ; produce external format
Q X
EXT(X) ; convert inverse internal date to internal date, add one day, then to external date
N SAVX ; temp scratch variable to hold value of X
S X=+($G(X)),X=9999999-X ; produce an internal date
S SAVX=X
S X=$$FMTE^XLFDT(X,"5ZD") D ^%DT I Y=-1 S SAVX=$$NOW^XLFDT ; if not valid date, set to NOW
S X=SAVX
S X=$$FMADD^XLFDT(X,1,0,0,0) ; add one day so any GAF data entered today will appear on output
S X=$$FMTE^XLFDT(X,"5ZD") ; output in external format
Q X
ETF(X) ; External to Fileman format
N %DT,Y S X=$G(X),%DT="PST" D ^%DT S X=Y S:+X'>0 X="" Q X
TOM(X) ; Tomorrow
S X=$$FMTE^XLFDT($$FMADD^XLFDT($$NOW^XLFDT,1,0,0,0),"5ZD") Q X
TOD(X) ; Today
S X=$$NOW^XLFDT Q X
DEC(X) ; Deceased Date
N %,%H,%I,%X,%T,VA,VADM,VAERR,DFN S DFN=+($G(X)) Q:DFN=0 "" Q:'$D(^DPT(+DFN,0)) ""
D DEM^VADPT S X=+$G(VADM(6)) S:X=0 X="" Q X
B(X,Y) ; Graph Bar
N GMTSGAF,GMTSCHAR,GMTSCW,GMTSLEN,GMTSI,GMTSBAR S GMTSGAF=$G(X),GMTSCW=+($G(Y)) Q:GMTSCW=0 ""
S GMTSCHAR="#" F Q:$E(GMTSGAF,1)'="0" S GMTSGAF=$E(GMTSGAF,2,$L(GMTSGAF))
S GMTSGAF=+GMTSGAF Q:GMTSGAF=0 ""
I GMTSGAF>99 S GMTSBAR="",$P(GMTSBAR,GMTSCHAR,GMTSCW)=GMTSCHAR
I GMTSGAF'>99 S GMTSI=GMTSCW/100,GMTSLEN=GMTSI*GMTSGAF,GMTSLEN=$FN(GMTSLEN,"",0),GMTSBAR="",$P(GMTSBAR,GMTSCHAR,GMTSLEN)=GMTSCHAR
S X=GMTSBAR Q X
GAF(X) ; 2 Digit GAF Score
S X=$E($G(X),1,3) Q:X=""!(X="---") "" S X=+X Q:X=0 " 0" S:$L(X)=1 X=" "_X S:$L(X)=2 X=" "_X Q X
DTM(X) ; Current Date and Time (External)
S X=$$NOW^XLFDT D REGDTM4^GMTSU Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSGAF 7665 printed Dec 13, 2024@01:57:34 Page 2
GMTSGAF ; SLC/KER - MH Gbl Assessment Funct (GAF) ; 6/20/05 1:44pm
+1 ;;2.7;Health Summary;**35,44,49,74**;Oct 20, 1995
+2 ;
+3 ; External References
+4 ; DBIA 10035 ^DPT(
+5 ; DBIA 10003 ^%DT
+6 ; DBIA 10088 DEM^VADPT
+7 ; DBIA 10103 $$FMADD^XLFDT
+8 ; DBIA 10103 $$FMTE^XLFDT
+9 ; DBIA 10103 $$NOW^XLFDT
+10 ; DBIA 2896 GAFHX^YSGAFAPI
+11 ;
+12 QUIT
EN ; Global Assessment Functioning Score
+1 NEW MAX
SET MAX=$SELECT(+($GET(GMTSNDM))>0:+($GET(GMTSNDM)),1:9999999)
+2 if +($GET(GMTSBEG))'>2700101
SET GMTSBEG=$$FMADD^XLFDT($PIECE($$NOW^XLFDT,".",1),-1095,0,0,1)
SET GMTSEND=$$FMADD^XLFDT($PIECE($$NOW^XLFDT,".",1),1,0,0,1)
SET GMTS2=9999999-GMTSBEG
SET GMTS1=9999999-GMTSEND
+3 if '$LENGTH($PIECE(GMTSBEG,".",2))
SET GMTSBEG=$$FMADD^XLFDT(GMTSBEG,0,0,0,1)
+4 if +($GET(GMTSEND))'>2700101!(+($GET(GMTSEND))>+($$FMADD^XLFDT($PIECE($$NOW^XLFDT,".",1),+1,0,0,2)))
SET GMTSEND=$$FMADD^XLFDT($PIECE($$NOW^XLFDT,".",1),1,0,0,1)
SET GMTS1=9999999-GMTSEND
+5 if '$LENGTH($PIECE(GMTSEND,".",2))
SET GMTSEND=$$FMADD^XLFDT(GMTSEND,0,0,0,1)
+6 if +($GET(GMTSEND))>0&(+($GET(GMTS1))=0)
SET GMTS1=9999999-GMTSEND
if +($GET(GMTSBEG))>0&(+($GET(GMTS2))=0)
SET GMTS2=9999999-GMTSBEG
+7 SET GMTSLO=+($GET(GMTSLO))
if GMTSLO=0
SET GMTSLO=3
SET GMTSLPG=+($GET(GMTSLPG))
SET GMTSDTM=$GET(GMTSDTM)
if '$LENGTH(GMTSDTM)
SET GMTSDTM=$$DTM
+8 if '$DATA(GMTSTITL)!('$LENGTH($GET(GMTSTITL)))
SET GMTSTITL="GLOBAL ASSESSMENT FUNCTIONING"
+9 SET DFN=+($GET(DFN))
if '$LENGTH($PIECE($GET(^DPT(DFN,0)),"^",1))
QUIT
+10 NEW %,%DT,%H,%I,%T,%X,I,N,VA,VADM,VAERR,X,Y,YS,YSGAF
+11 NEW GMTSBAR,GMTSCNT,GMTSCOM,GMTSCORE,GMTSCS,GMTSCW,GMTSDATE,GMTSDT
+12 NEW GMTSGAF,GMTSGAF1,GMTSGAF2,GMTSGAF3,GMTSGAFN,GMTSI,GMTSJ,GMTSLEN,GMTSPROV,GMTSRV
+13 SET GMTSGAF1=$$EXT(+($GET(GMTS1)))
SET GMTSGAF2=$$ITM(+($GET(GMTS2)))
SET GMTSGAF3=$$TOM
+14 SET GMTSGAFN=+($GET(MAX))
if GMTSGAFN=0
SET GMTSGAFN=10
+15 SET GMTSCW(0)=+($GET(IOM))
if GMTSCW(0)=0
SET GMTSCW(0)=80
+16 SET GMTSCW(1)=5
SET GMTSCW(2)=10
SET GMTSCW(3)=20
SET GMTSCW(4)=GMTSCW(0)-(GMTSCW(1)+GMTSCW(2)+GMTSCW(3)+8)
+17 SET GMTSCW("L")=(GMTSCW(1)+GMTSCW(2)+GMTSCW(3)+GMTSCW(4)+6)
+18 SET GMTSCS(1)=1
SET GMTSCS(2)=GMTSCS(1)+GMTSCW(1)+2
SET GMTSCS(3)=GMTSCS(2)+GMTSCW(2)+2
SET GMTSCS(4)=GMTSCS(3)+GMTSCW(3)+2
+19 SET YS("DFN")=DFN
SET YS("BEGIN")=$SELECT($LENGTH(GMTSGAF2):GMTSGAF2,1:GMTSGAF3)
+20 SET YS("END")=$SELECT($LENGTH(GMTSGAF1):GMTSGAF1,1:"01/01/1970")
SET YS("LIMIT")=GMTSGAFN
+21 DO GET
if '$DATA(^TMP($JOB,"GMTSGAF",DFN))
QUIT
DO OUT
QUIT
OUT ; Output
+1 NEW GMTSI,GMTSJ,GMTSCORE,GMTSDATE,GMTSPROV,GMTSCOM
SET DFN=+($GET(DFN))
if DFN=0
QUIT
DO HDR
SET GMTSI=0
FOR
SET GMTSI=$ORDER(^TMP($JOB,"GMTSGAF",DFN,GMTSI))
if +GMTSI=0
QUIT
Begin DoDot:1
+2 SET GMTSJ=$GET(^TMP($JOB,"GMTSGAF",DFN,GMTSI))
+3 SET GMTSCORE=$PIECE(GMTSJ,"^",1)
SET GMTSDATE=$PIECE(GMTSJ,"^",2)
SET GMTSPROV=$PIECE(GMTSJ,"^",3)
SET GMTSCOM=$PIECE(GMTSJ,"^",4)
if GMTSCORE=""&(GMTSDATE["----")&($LENGTH(GMTSCOM))
SET GMTSCORE=">>"
DO LINE
End DoDot:1
+4 KILL ^TMP($JOB,"GMTSGAF",DFN)
QUIT
LINE ; Output One Line
+1 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if GMTSNPG=1
DO HDR
WRITE ?GMTSCS(1),$JUSTIFY($EXTRACT(GMTSCORE,1,3),3),?GMTSCS(2),GMTSDATE,?GMTSCS(3),$EXTRACT(GMTSPROV,1,GMTSCW(3)),?GMTSCS(4),GMTSCOM,!
QUIT
HDR ; Header
+1 NEW GMTSI
SET GMTSI=""
SET $PIECE(GMTSI,"-",+($GET(GMTSCW("L"))))="-"
+2 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if GMTSNPG=1
GOTO HDR
WRITE ?GMTSCS(1)," GAF ",?GMTSCS(2),"Date",!
+3 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if GMTSNPG=1
GOTO HDR
WRITE ?GMTSCS(1),"Score",?GMTSCS(2),"Determined",?GMTSCS(3),"Determined by",?GMTSCS(4),"Graph/Comment",!
+4 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if GMTSNPG=1
GOTO HDR
WRITE ?GMTSCS(1),GMTSI,!
+5 QUIT
GET ; Get and Format Data
+1 NEW %DT,X,Y,GMTSGPH,GMTSCORE,GMTSDT,GMTSDATE,GMTSPROV,GMTSCOM
SET DFN=+($GET(DFN))
SET GMTSGPH=0
KILL ^TMP($JOB,"GMTSGAF",DFN),YSGAF
DO GAFHX^YSGAFAPI(.YSGAF,.YS)
DO SPC
+2 IF +($PIECE($GET(YSGAF("DEC")),".",1))>0
Begin DoDot:1
+3 SET GMTSDT=+($PIECE($GET(YSGAF("DEC")),".",1))
SET GMTSCOM="Deceased ("_$$FMTE^XLFDT(GMTSDT,"5ZD")_")"
DO SD(GMTSDT,DFN,"","","",GMTSCOM)
End DoDot:1
+4 IF +($PIECE($GET(YSGAF("DUE")),".",1))>0
Begin DoDot:1
+5 SET GMTSDT=+($PIECE($GET(YSGAF("DUE")),".",1))
if GMTSDT>$$TOD
QUIT
SET GMTSCOM="Due since "_$$FMTE^XLFDT(GMTSDT,"5ZD")
DO SD(GMTSDT,DFN,"","","",GMTSCOM)
End DoDot:1
+6 NEW I
SET I=1
FOR
SET I=$ORDER(YSGAF(I))
if +I=0
QUIT
Begin DoDot:1
+7 SET GMTSDT=$PIECE(YSGAF(I),"^",1)
SET GMTSDATE=$PIECE(GMTSDT,".",1)
SET GMTSDATE=$$FMTE^XLFDT(GMTSDATE,"5ZD")
+8 if +($GET(YSGAF("DEC")))>0&(+GMTSDATE>+($GET(YSGAF("DEC"))))
QUIT
+9 SET GMTSCORE=$PIECE(YSGAF(I),"^",5)
SET GMTSPROV=$PIECE(YSGAF(I),"^",7)
+10 SET GMTSCOM=+($PIECE($GET(YSGAF("ERR",I)),".",1))
if +GMTSCOM=0
SET GMTSCOM=""
+11 if +GMTSCOM>0
SET GMTSCOM="Entered in error ("_$$FMTE^XLFDT(GMTSCOM,"5ZD")_")"
+12 if GMTSCOM=""
SET GMTSCOM=$$B(GMTSCORE,31)
+13 if '$DATA(YSGAF("ERR",I))
DO SD(GMTSDT,DFN,GMTSCORE,GMTSDATE,GMTSPROV,GMTSCOM)
End DoDot:1
+14 QUIT
SPC ; Get Special Case (Deceased, Due, Entered-in-Error)
+1 NEW GMTSI
SET YSGAF("P")=$PIECE($GET(^DPT(+($GET(DFN)),0)),"^",1)
+2 SET GMTSI=$$DEC(+($GET(DFN)))
if +GMTSI>0
SET YSGAF("DEC")=GMTSI
IF +GMTSI=0
SET GMTSI=$$DUE
if +GMTSI>0
SET YSGAF("DUE")=GMTSI
+3 if +($GET(YSGAF("DEC")))>0
KILL YSGAF("DUE")
SET GMTSI=$$ERR
if +GMTSI>0
SET YSGAF("ERR")=GMTSI
+4 QUIT
SD(GMTSI,DFN,GMTSCORE,GMTSDATE,GMTSPROV,GMTSCOM) ; Save Data
+1 NEW GMTSIG
SET (GMTSCORE,GMTSIG)=$GET(GMTSCORE)
SET GMTSCORE=$$GAF(GMTSCORE)
SET DFN=+($GET(DFN))
+2 SET GMTSIG=100-(+($GET(GMTSIG)))
+3 SET GMTSI=+($GET(GMTSI))
SET GMTSI=9999999.999999-GMTSI
+4 SET GMTSPROV=$GET(GMTSPROV)
SET GMTSDATE=$GET(GMTSDATE)
+5 SET GMTSIG=GMTSI_GMTSIG_GMTSPROV_GMTSDATE
+6 if GMTSDATE=""
SET GMTSDATE="--/--/----"
+7 SET ^TMP($JOB,"GMTSGAF",DFN,GMTSIG)=GMTSCORE_"^"_GMTSDATE_"^"_GMTSPROV_"^"_$GET(GMTSCOM)
+8 QUIT
ERR(X) ; Entered in Error
+1 NEW GMTSCNT,GMTSI,GMTSGAF,GMTSJ,GMTSDATE
SET (GMTSCNT,GMTSI)=0
SET GMTSDATE=""
FOR
SET GMTSI=$ORDER(YSGAF(GMTSI))
if +GMTSI=0
QUIT
Begin DoDot:1
+2 SET GMTSGAF=$PIECE(YSGAF(GMTSI),"^",8)
if GMTSGAF'["entered in error"
QUIT
+3 SET YSGAF("ERR")=""
FOR GMTSJ=1:1:$LENGTH(GMTSGAF," ")
Begin DoDot:2
+4 if $PIECE(GMTSGAF," ",GMTSJ)["@"&(GMTSJ>2)
SET GMTSDATE=$PIECE(GMTSGAF," ",GMTSJ-1,GMTSJ)
if $LENGTH(GMTSDATE)
SET GMTSDATE=$$ETF(GMTSDATE)
End DoDot:2
+5 if $LENGTH(GMTSDATE)
SET YSGAF("ERR",GMTSI)=GMTSDATE
SET GMTSCNT=GMTSCNT+1
End DoDot:1
+6 SET X=GMTSCNT
QUIT X
DUE(X) ; GAF Score Due Date
+1 if '$DATA(YSGAF(2))
SET YSGAF(1)="[NO DATA]"
NEW GMTSI,GMTSJ,GMTSDATE
SET (GMTSI,GMTSJ,GMTSDATE)=0
+2 FOR
SET GMTSI=$ORDER(YSGAF(GMTSI))
if +GMTSI=0
QUIT
SET GMTSJ=$PIECE(YSGAF(GMTSI),"^",1)
if GMTSJ>GMTSDATE
SET GMTSDATE=GMTSJ
+3 SET GMTSDATE=$SELECT(GMTSDATE>0:$$FMADD^XLFDT(GMTSDATE,90,0,0,0),1:"")
SET X=GMTSDATE
QUIT X
ITM(X) ; convert inverse internal date to internal date to external date
+1 ; temp scratch variable to hold value of X
NEW SAVX
+2 ; produce an internal date
SET X=+($GET(X))
SET X=9999999-X
+3 SET SAVX=X
+4 ; if not valid date, default to 3 years ago
SET X=$$FMTE^XLFDT(X,"5ZD")
DO ^%DT
IF Y=-1
Begin DoDot:1
+5 SET X1=$$NOW^XLFDT
SET X2=-1095
DO C^%DTC
SET SAVX=X
End DoDot:1
+6 SET X=SAVX
+7 ; produce external format
SET X=$$FMTE^XLFDT(X,"5ZD")
+8 QUIT X
EXT(X) ; convert inverse internal date to internal date, add one day, then to external date
+1 ; temp scratch variable to hold value of X
NEW SAVX
+2 ; produce an internal date
SET X=+($GET(X))
SET X=9999999-X
+3 SET SAVX=X
+4 ; if not valid date, set to NOW
SET X=$$FMTE^XLFDT(X,"5ZD")
DO ^%DT
IF Y=-1
SET SAVX=$$NOW^XLFDT
+5 SET X=SAVX
+6 ; add one day so any GAF data entered today will appear on output
SET X=$$FMADD^XLFDT(X,1,0,0,0)
+7 ; output in external format
SET X=$$FMTE^XLFDT(X,"5ZD")
+8 QUIT X
ETF(X) ; External to Fileman format
+1 NEW %DT,Y
SET X=$GET(X)
SET %DT="PST"
DO ^%DT
SET X=Y
if +X'>0
SET X=""
QUIT X
TOM(X) ; Tomorrow
+1 SET X=$$FMTE^XLFDT($$FMADD^XLFDT($$NOW^XLFDT,1,0,0,0),"5ZD")
QUIT X
TOD(X) ; Today
+1 SET X=$$NOW^XLFDT
QUIT X
DEC(X) ; Deceased Date
+1 NEW %,%H,%I,%X,%T,VA,VADM,VAERR,DFN
SET DFN=+($GET(X))
if DFN=0
QUIT ""
if '$DATA(^DPT(+DFN,0))
QUIT ""
+2 DO DEM^VADPT
SET X=+$GET(VADM(6))
if X=0
SET X=""
QUIT X
B(X,Y) ; Graph Bar
+1 NEW GMTSGAF,GMTSCHAR,GMTSCW,GMTSLEN,GMTSI,GMTSBAR
SET GMTSGAF=$GET(X)
SET GMTSCW=+($GET(Y))
if GMTSCW=0
QUIT ""
+2 SET GMTSCHAR="#"
FOR
if $EXTRACT(GMTSGAF,1)'="0"
QUIT
SET GMTSGAF=$EXTRACT(GMTSGAF,2,$LENGTH(GMTSGAF))
+3 SET GMTSGAF=+GMTSGAF
if GMTSGAF=0
QUIT ""
+4 IF GMTSGAF>99
SET GMTSBAR=""
SET $PIECE(GMTSBAR,GMTSCHAR,GMTSCW)=GMTSCHAR
+5 IF GMTSGAF'>99
SET GMTSI=GMTSCW/100
SET GMTSLEN=GMTSI*GMTSGAF
SET GMTSLEN=$FNUMBER(GMTSLEN,"",0)
SET GMTSBAR=""
SET $PIECE(GMTSBAR,GMTSCHAR,GMTSLEN)=GMTSCHAR
+6 SET X=GMTSBAR
QUIT X
GAF(X) ; 2 Digit GAF Score
+1 SET X=$EXTRACT($GET(X),1,3)
if X=""!(X="---")
QUIT ""
SET X=+X
if X=0
QUIT " 0"
if $LENGTH(X)=1
SET X=" "_X
if $LENGTH(X)=2
SET X=" "_X
QUIT X
DTM(X) ; Current Date and Time (External)
+1 SET X=$$NOW^XLFDT
DO REGDTM4^GMTSU
QUIT X
