YSGAF1 ;ASF/ALB- GLOBAL ASSESSMENT OF FUNCTIONNING CONT;9/25/97 11:19 ;11/10/97 16:08
;;5.01;MENTAL HEALTH;**33,187**;Dec 30, 1994;Build 73
;
Q
ONELOC ;single hospital location
N DIC,Y
S YSCLIN="",YSCNAME=""
S DIC="^SC(",DIC(0)="AEQMZ" D ^DIC Q:Y<1
S YSCLIN=+Y,YSCNAME=$P(Y,U,2)
S YSSTOP=$P(Y(0),U,7) S:YSSTOP YSSTOP=$P($G(^DIC(40.7,YSSTOP,0)),U,2) ;ASF 9/30
I YSSTOP>499&(YSSTOP<600) Q
W !,YSCNAME," does not have a mental health stop code"
S DIR("A")="Do you wish to continue? ",DIR("B")="No",DIR(0)="Y" D ^DIR
I Y'=1 D ONELOC
Q
DATE ;
N %DT
S %DT("A")="Enter Report Date: ",%DT("B")="T",%DT="AEF" D ^%DT
S YSDATE=Y
Q
ONLYREQ ;only > ysdays
S YSONLY=""
K DIR S DIR(0)="Y",DIR("A")="Show only patients who do not have a GAF within "_YSDAYS_" days",DIR("B")="Yes" D ^DIR K DIR
Q:$D(DIRUT) S YSONLY=Y
Q
LP1 ;loop to create tmp pt list
K ^TMP("YSGAF",$J)
S YSDD=YSDATE
F S YSDD=$O(^SC(YSCLIN,"S",YSDD)) Q:YSDD<1!(YSDD\1-YSDATE) D LP2
Q
LP2 ;apps at one time
S K=0 F S K=$O(^SC(YSCLIN,"S",YSDD,1,K)) Q:K<1 D:$G(^SC(YSCLIN,"S",YSDD,1,K,0))
. S YSG=^SC(YSCLIN,"S",YSDD,1,K,0)
. S DFN=+YSG,YSPTN=$P(^DPT(DFN,0),U)
. Q:$P($G(^DPT(DFN,"S",YSDD,0)),U,2)'="" ;dont list if cancelled, noshow or ip
. S ^TMP("YSGAF",$J,"A",YSPTN,DFN)=""
Q
HX ;GAF history
N %DT,DA,DIE,DIR,DIRUT,DLAYGO,DR,K,VA,VADM,X,X1,X2,Y,YSCLIN,YSCNAME,YSDA,YSDATE,YSDAYS,YSDD,YSDXEG,YSDXEL,YSDXEN,YSG,YSGAFLC,YSGAFLD,YSGAFLN,YSGC,YSGD,YSGN,YSGR,YSGT,YSLINE,YSN,YSONLY,YSOUT,YSPAGE,YSPTN,YSRULE,YSSTOP
K DIC,DFN D ^YSLRP Q:'$D(DFN)
;ASK DEVICE
S %ZIS="QM"
D ^%ZIS
Q:$G(POP)
I $D(IO("Q")) D Q
.N ZTRTN,ZTDESC,ZTSAVE
.S ZTRTN="QHX^YSGAF1"
.S ZTDESC="YSGAF1 HX PRINT"
. S ZTSAVE("DFN")=""
.D ^%ZTLOAD
.D HOME^%ZIS
.Q
U IO
QHX ;Queued Task Entry Point
S:$D(ZTQUEUED) ZTREQ="@"
D DEM^VADPT
K ^TMP("YSGAF",$J)
D HXLP
D TOP
I '$D(^TMP("YSGAF",$J,"H")) W !!,"No previous GAF's on file for this patient" Q
S YSOUT=1
S YSDD=0 F S YSDD=$O(^TMP("YSGAF",$J,"H",YSDD)) Q:YSDD'>0 S YSN=0 F S YSN=$O(^TMP("YSGAF",$J,"H",YSDD,YSN)) Q:YSN'>0 D D:$Y+4>IOSL BOT Q:YSOUT<1
. S YSG=^TMP("YSGAF",$J,"H",YSDD,YSN)
. S Y=$P(YSG,U,2) W !,$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3),$S($L($P(YSG,U,4)):"Err",1:" ")
. I $P(YSG,U,3) W $E($P($G(^VA(200,$P(YSG,U,3),0)),U),1,15)
. W ?26,$J(+YSG,3)
. W " ",$E(YSGR,1,+YSG\2)
D ^%ZISC
Q
HXLP ;
S YSDD=0 F S YSDD=$O(^YSD(627.8,"AX5",DFN,YSDD)) Q:YSDD'>0 S YSN=0 F S YSN=$O(^YSD(627.8,"AX5",DFN,YSDD,YSN)) Q:YSN'>0 D
. S ^TMP("YSGAF",$J,"H",YSDD,YSN)=$P($G(^YSD(627.8,YSN,60)),U,3)_U_$P($G(^YSD(627.8,YSN,0)),U,3)_U_$P($G(^YSD(627.8,YSN,0)),U,4)_U_$G(^YSD(627.8,YSN,80,1,0))
Q
TOP ;
S YSGT=" 10 20 30 40 50 60 70 80 90 |"
S YSGR="####|####|####|####|####|####|####|####|####|####|"
W @IOF,"Global Assessment of Functioning Historical Listing"
W !,VADM(1),?$X+5,"xxx-xx-",VA("BID"),?45,"printed: "
D NOW^%DTC S Y=% X ^DD("DD") W Y
S YSLINE="",$P(YSLINE,"-",79)="" W !,YSLINE
W !,"Date",?10,"Clinician",?26,"GAF",?30,YSGT
Q
BOT ;page end
K DIR S YSOUT=1 I IOST'?1"C".E D TOP Q
W !! S DIR(0)="E" D ^DIR
S YSOUT=Y D:Y=1 TOP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSGAF1 3194 printed Oct 16, 2024@18:15:14 Page 2
YSGAF1 ;ASF/ALB- GLOBAL ASSESSMENT OF FUNCTIONNING CONT;9/25/97 11:19 ;11/10/97 16:08
+1 ;;5.01;MENTAL HEALTH;**33,187**;Dec 30, 1994;Build 73
+2 ;
+3 QUIT
ONELOC ;single hospital location
+1 NEW DIC,Y
+2 SET YSCLIN=""
SET YSCNAME=""
+3 SET DIC="^SC("
SET DIC(0)="AEQMZ"
DO ^DIC
if Y<1
QUIT
+4 SET YSCLIN=+Y
SET YSCNAME=$PIECE(Y,U,2)
+5 ;ASF 9/30
SET YSSTOP=$PIECE(Y(0),U,7)
if YSSTOP
SET YSSTOP=$PIECE($GET(^DIC(40.7,YSSTOP,0)),U,2)
+6 IF YSSTOP>499&(YSSTOP<600)
QUIT
+7 WRITE !,YSCNAME," does not have a mental health stop code"
+8 SET DIR("A")="Do you wish to continue? "
SET DIR("B")="No"
SET DIR(0)="Y"
DO ^DIR
+9 IF Y'=1
DO ONELOC
+10 QUIT
DATE ;
+1 NEW %DT
+2 SET %DT("A")="Enter Report Date: "
SET %DT("B")="T"
SET %DT="AEF"
DO ^%DT
+3 SET YSDATE=Y
+4 QUIT
ONLYREQ ;only > ysdays
+1 SET YSONLY=""
+2 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Show only patients who do not have a GAF within "_YSDAYS_" days"
SET DIR("B")="Yes"
DO ^DIR
KILL DIR
+3 if $DATA(DIRUT)
QUIT
SET YSONLY=Y
+4 QUIT
LP1 ;loop to create tmp pt list
+1 KILL ^TMP("YSGAF",$JOB)
+2 SET YSDD=YSDATE
+3 FOR
SET YSDD=$ORDER(^SC(YSCLIN,"S",YSDD))
if YSDD<1!(YSDD\1-YSDATE)
QUIT
DO LP2
+4 QUIT
LP2 ;apps at one time
+1 SET K=0
FOR
SET K=$ORDER(^SC(YSCLIN,"S",YSDD,1,K))
if K<1
QUIT
if $GET(^SC(YSCLIN,"S",YSDD,1,K,0))
Begin DoDot:1
+2 SET YSG=^SC(YSCLIN,"S",YSDD,1,K,0)
+3 SET DFN=+YSG
SET YSPTN=$PIECE(^DPT(DFN,0),U)
+4 ;dont list if cancelled, noshow or ip
if $PIECE($GET(^DPT(DFN,"S",YSDD,0)),U,2)'=""
QUIT
+5 SET ^TMP("YSGAF",$JOB,"A",YSPTN,DFN)=""
End DoDot:1
+6 QUIT
HX ;GAF history
+1 NEW %DT,DA,DIE,DIR,DIRUT,DLAYGO,DR,K,VA,VADM,X,X1,X2,Y,YSCLIN,YSCNAME,YSDA,YSDATE,YSDAYS,YSDD,YSDXEG,YSDXEL,YSDXEN,YSG,YSGAFLC,YSGAFLD,YSGAFLN,YSGC,YSGD,YSGN,YSGR,YSGT,YSLINE,YSN,YSONLY,YSOUT,YSPAGE,YSPTN,YSRULE,YSSTOP
+2 KILL DIC,DFN
DO ^YSLRP
if '$DATA(DFN)
QUIT
+3 ;ASK DEVICE
+4 SET %ZIS="QM"
+5 DO ^%ZIS
+6 if $GET(POP)
QUIT
+7 IF $DATA(IO("Q"))
Begin DoDot:1
+8 NEW ZTRTN,ZTDESC,ZTSAVE
+9 SET ZTRTN="QHX^YSGAF1"
+10 SET ZTDESC="YSGAF1 HX PRINT"
+11 SET ZTSAVE("DFN")=""
+12 DO ^%ZTLOAD
+13 DO HOME^%ZIS
+14 QUIT
End DoDot:1
QUIT
+15 USE IO
QHX ;Queued Task Entry Point
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 DO DEM^VADPT
+3 KILL ^TMP("YSGAF",$JOB)
+4 DO HXLP
+5 DO TOP
+6 IF '$DATA(^TMP("YSGAF",$JOB,"H"))
WRITE !!,"No previous GAF's on file for this patient"
QUIT
+7 SET YSOUT=1
+8 SET YSDD=0
FOR
SET YSDD=$ORDER(^TMP("YSGAF",$JOB,"H",YSDD))
if YSDD'>0
QUIT
SET YSN=0
FOR
SET YSN=$ORDER(^TMP("YSGAF",$JOB,"H",YSDD,YSN))
if YSN'>0
QUIT
Begin DoDot:1
+9 SET YSG=^TMP("YSGAF",$JOB,"H",YSDD,YSN)
+10 SET Y=$PIECE(YSG,U,2)
WRITE !,$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3),$SELECT($LENGTH($PIECE(YSG,U,4)):"Err",1:" ")
+11 IF $PIECE(YSG,U,3)
WRITE $EXTRACT($PIECE($GET(^VA(200,$PIECE(YSG,U,3),0)),U),1,15)
+12 WRITE ?26,$JUSTIFY(+YSG,3)
+13 WRITE " ",$EXTRACT(YSGR,1,+YSG\2)
End DoDot:1
if $Y+4>IOSL
DO BOT
if YSOUT<1
QUIT
+14 DO ^%ZISC
+15 QUIT
HXLP ;
+1 SET YSDD=0
FOR
SET YSDD=$ORDER(^YSD(627.8,"AX5",DFN,YSDD))
if YSDD'>0
QUIT
SET YSN=0
FOR
SET YSN=$ORDER(^YSD(627.8,"AX5",DFN,YSDD,YSN))
if YSN'>0
QUIT
Begin DoDot:1
+2 SET ^TMP("YSGAF",$JOB,"H",YSDD,YSN)=$PIECE($GET(^YSD(627.8,YSN,60)),U,3)_U_$PIECE($GET(^YSD(627.8,YSN,0)),U,3)_U_$PIECE($GET(^YSD(627.8,YSN,0)),U,4)_U_$GET(^YSD(627.8,YSN,80,1,0))
End DoDot:1
+3 QUIT
TOP ;
+1 SET YSGT=" 10 20 30 40 50 60 70 80 90 |"
+2 SET YSGR="####|####|####|####|####|####|####|####|####|####|"
+3 WRITE @IOF,"Global Assessment of Functioning Historical Listing"
+4 WRITE !,VADM(1),?$X+5,"xxx-xx-",VA("BID"),?45,"printed: "
+5 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
WRITE Y
+6 SET YSLINE=""
SET $PIECE(YSLINE,"-",79)=""
WRITE !,YSLINE
+7 WRITE !,"Date",?10,"Clinician",?26,"GAF",?30,YSGT
+8 QUIT
BOT ;page end
+1 KILL DIR
SET YSOUT=1
IF IOST'?1"C".E
DO TOP
QUIT
+2 WRITE !!
SET DIR(0)="E"
DO ^DIR
+3 SET YSOUT=Y
if Y=1
DO TOP
+4 QUIT
