YSGAF ;ALB/ASF-GLOBAL ASSESSMENT OF FUNCTIONING ;11/10/97 16:17
;;5.01;MENTAL HEALTH;**33,37,40,42,43,51,49,187**;Dec 30, 1994;Build 73
;
Q
CLENT ;
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,YSGAFER
W @IOF,"Clinic Entry: Global Assessment of Functioning",!
D ONELOC^YSGAF1 Q:YSCLIN=""
D DATE^YSGAF1 Q:YSDATE<1
S YSDAYS=90
D ONLYREQ^YSGAF1 Q:YSONLY=""
D LP1^YSGAF1
I '$D(^TMP("YSGAF",$J)) W !,"No GAF's to enter" Q
CE1 S YSN="",YSOUT=0 F S YSN=$O(^TMP("YSGAF",$J,"A",YSN)) Q:YSN=""!(YSOUT) S DFN=0 F S DFN=$O(^TMP("YSGAF",$J,"A",YSN,DFN)) Q:DFN'>0 D
.D RULE Q:('YSRULE)&(YSONLY)
.W !
.D DISP5,ADD5
Q
RULE ;business rule for need dx
S YSRULE=0
D CK
I YSGAFLD'?7N.E S YSRULE=1 Q
S X1=DT,X2=YSGAFLD D ^%DTC
S:X>YSDAYS YSRULE=1
Q
CK ;check last Axis 5
S (YSGAFLN,YSGAFLD,YSGAFLC,YSGAFER)=""
S YSDXEL=$O(^YSD(627.8,"AX5",DFN,-1))
Q:YSDXEL<1
S YSDXEN=$O(^YSD(627.8,"AX5",DFN,YSDXEL,-1))
Q:YSDXEN<1
S YSDXEG=$G(^YSD(627.8,YSDXEN,0))
S YSGAFLD=$P(YSDXEG,U,3),YSGAFLC=$P(YSDXEG,U,4)
S YSDXEG=$G(^YSD(627.8,YSDXEN,60))
S YSGAFLN=$P(YSDXEG,U,3)
S YSGAFER=$G(^YSD(627.8,YSDXEN,80,1,0))
Q
PRINT ;
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
S YSDAYS=90
D ONELOC^YSGAF1 Q:YSCLIN=""
D DATE^YSGAF1 Q:YSDATE<1
D ONLYREQ^YSGAF1 Q:YSONLY=""
;ASK DEVICE
S %ZIS="QM"
D ^%ZIS
Q:$G(POP)
I $D(IO("Q")) D Q
.N ZTRTN,ZTDESC,ZTSAVE
.S ZTRTN="QPRT^YSGAF"
.S ZTDESC="YSGAF PRINT"
.F ZZ="YSONLY","YSDAYS","YSCLIN","YSCNAME","YSDATE" S ZTSAVE(ZZ)=""
.D ^%ZTLOAD
.D HOME^%ZIS
.Q
U IO
QPRT ;Queued Task Entry Point
S:$D(ZTQUEUED) ZTREQ="@"
D LP1^YSGAF1
S YSPAGE=0 D TOP
I '$D(^TMP("YSGAF",$J)) W !,"No appointments found" Q
PR1 S YSN="",YSOUT=1 F S YSN=$O(^TMP("YSGAF",$J,"A",YSN)) Q:YSN="" S DFN=0 F S DFN=$O(^TMP("YSGAF",$J,"A",YSN,DFN)) Q:DFN'>0 D D:$Y+4>IOSL BOT Q:YSOUT<1
. D CK,RULE
.Q:('YSRULE)&(YSONLY)
. D DEM^VADPT
.W !,$E(YSN,1,25),?26,VA("BID"),?32,$S($L(YSGAFER):"Er",YSGAFLN:YSGAFLN,1:"--")," ",$S(YSGAFLD:$$FMTE^XLFDT(YSGAFLD,"5ZD"),1:" ")
. W " "_$S(YSRULE:"**",1:" ")_"______ __________________"
D ^%ZISC
Q
TOP ;print header
S YSPAGE=YSPAGE+1
I '$D(YSLINE) S YSLINE="",$P(YSLINE,"-",79)=""
W @IOF,"GAF List Clinic: ",YSCNAME," **= > than ",YSDAYS," days"
W !,"Appointment Date: ",$$FMTE^XLFDT(YSDATE,"5ZD")
W ?32,"Last GAF New",?65,"page: ",YSPAGE
W !?32,"GAF Date GAF Clinician",!,YSLINE
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
PTENT ;patient entry
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,YSGAFER
W @IOF,"Global Assessment of functioning"
F K DFN W ! D ^YSLRP Q:'$D(DFN) D DISP5,ADD5
Q
DISP5 ;display last axis5
Q:'$D(DFN)
D DEM^VADPT
W !,VADM(1),?35,"SSN: xxx-xx-",VA("BID"),?55,"DOB: ",$P(VADM(3),U,2)
DISP51 D CK
I YSGAFLN D
. W !?4,"Last GAF: ",YSGAFLN," on: "
. S Y=YSGAFLD X ^DD("DD") W Y
. W " by: ",$S(+$G(YSGAFLC):$P(^VA(200,YSGAFLC,0),U),1:"--> No provider entered for this GAF score")
. I $L(YSGAFER)>1 W !,YSGAFER
I YSGAFLN<1 W !?4,"no previous GAF"
Q
ADD5 ;add axis 5 dx
W !!
K DIR S DIR(0)="N^1:100:0",DIR("A")="GAF Score",DIR("?")="Enter the Global Assessment of Functioning : 1 to 100",DIR("??")="YS-GAF SCALE"
;I $D(YSGAFLN) S:YSGAFLN?1N.N DIR("B")=YSGAFLN
D ^DIR S YSGN=Y S:X?1"^^".E YSOUT=1
I $D(DIRUT) W !,"No GAF will be entered. Enter ^^ to end loop.",$C(7) Q
K DIR S DIR(0)="DA^2961001:NOW:TX",DIR("A")="Diagnosis date/time: ",DIR("B")="NOW"
D ^DIR S:Y>0 YSGD=Y
I $D(DIRUT) W !,"No GAF will be entered",$C(7) Q
K DIR,DIC S DIC="^VA(200,",DIC(0)="AEM",DIC("A")="Assessing Clinician: ",DIC("B")=$P(^VA(200,DUZ,0),U)
D ^DIC K DIC S:Y>0 YSGC=+Y
I Y<1 W !,"No GAF will be entered",$C(7) Q
K DD,DO,DA,DINUM
S X="NOW",%DT="TR" D ^%DT S X=Y
S DIC="^YSD(627.8,",DIC(0)="L",DLAYGO=627.8 D FILE^DICN Q:Y'>0 S YSDA=+Y
D PATSTAT^YSDX3B
S DIE="^YSD(627.8,",DA=YSDA,DR=".02////"_DFN_";.03////"_YSGD_";.04////"_YSGC_";.05////"_DUZ_";65////"_YSGN_";66////"_YSSTAT
L +^YSD(627.8,YSDA):9999 Q:'$T
D ^DIE
L -^YSD(627.8,YSDA)
D EN^YSGAFOBX(YSDA)
Q
;
RET(YSX) ;This extrinsic returns the most recent GAF score, GAF
;diagnosis date and physician/provider performing the diagnosis,
;for the internal entry number given (via variable YSX.) If no
;GAF score data is on file for this internal entry number, -1 is
;returned.
N YSHOLD
S (YSHOLD)=""
S YSHOLD=$O(^YSD(627.8,"C",YSX,""),-1)
IF YSHOLD D
.S YSZ=$P($G(^YSD(627.8,YSHOLD,60)),"^",3)
.S YSZ=YSZ_"^"_$P($G(^YSD(627.8,YSHOLD,0)),"^",3)
.S YSZ=YSZ_"^"_$P($G(^YSD(627.8,YSHOLD,0)),"^",4)
ELSE S YSZ=-1
Q YSZ
;
UPD(YSPN,YSGN,YSGD,YSGC,YSPT) ;Update GAF information
; YSPN - Patient Name
; YSGN - GAF Score (Axis 5)
; YSGD - Date/Time of Diagnosis
; YSGC - Diagnosis By
; YSPT - Patient Type ('I'npatient or 'O'utpatient)
S YSERR=0
I '$G(YSPN) D
.W !," The Patient IEN is required!!!",!
.S YSERR=1
.Q
;
I '$G(YSGN) D
.W !," The GAF Score is required!!!",!
.S YSERR=1
.Q
;
I '$G(YSGD) D
.W " The Observation Date/Time is required!!!",!
.S YSERR=1
.Q
;
I '$G(YSGC) D
.W " The Provider is required!!!",!
.S YSERR=1
.Q
;
QUIT:YSERR ;---->
;
K DD,DO,DA,DINUM
S DLAYGO=627.8,X="NOW",%DT="TR" D ^%DT S X=Y
S DIC="^YSD(627.8,",DIC(0)="L"
D FILE^DICN Q:Y'>0 S YSDA=+Y
S DFN=+YSPN
D PATSTAT^YSDX3B
S DIE="^YSD(627.8,",DA=YSDA
S DR=".02////"_YSPN_";.03////"_YSGD_";.04////"_YSGC_";.05////"_DUZ
S DR=DR_";65////"_YSGN_";66////"_YSSTAT
L +^YSD(627.8,YSDA):9999 Q:'$T
D ^DIE
L -^YSD(627.8,YSDA)
D EN^YSGAFOBX(YSDA)
K %DT,DA,DIC,DIE,DLAYGO,DR,X,Y,YSDA,YSPN,YSGN,YSGD,YSGC,YSSTAT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSGAF 6296 printed Sep 23, 2025@19:50:35 Page 2
YSGAF ;ALB/ASF-GLOBAL ASSESSMENT OF FUNCTIONING ;11/10/97 16:17
+1 ;;5.01;MENTAL HEALTH;**33,37,40,42,43,51,49,187**;Dec 30, 1994;Build 73
+2 ;
+3 QUIT
CLENT ;
+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,YSGAFER
+2 WRITE @IOF,"Clinic Entry: Global Assessment of Functioning",!
+3 DO ONELOC^YSGAF1
if YSCLIN=""
QUIT
+4 DO DATE^YSGAF1
if YSDATE<1
QUIT
+5 SET YSDAYS=90
+6 DO ONLYREQ^YSGAF1
if YSONLY=""
QUIT
+7 DO LP1^YSGAF1
+8 IF '$DATA(^TMP("YSGAF",$JOB))
WRITE !,"No GAF's to enter"
QUIT
CE1 SET YSN=""
SET YSOUT=0
FOR
SET YSN=$ORDER(^TMP("YSGAF",$JOB,"A",YSN))
if YSN=""!(YSOUT)
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^TMP("YSGAF",$JOB,"A",YSN,DFN))
if DFN'>0
QUIT
Begin DoDot:1
+1 DO RULE
if ('YSRULE)&(YSONLY)
QUIT
+2 WRITE !
+3 DO DISP5
DO ADD5
End DoDot:1
+4 QUIT
RULE ;business rule for need dx
+1 SET YSRULE=0
+2 DO CK
+3 IF YSGAFLD'?7N.E
SET YSRULE=1
QUIT
+4 SET X1=DT
SET X2=YSGAFLD
DO ^%DTC
+5 if X>YSDAYS
SET YSRULE=1
+6 QUIT
CK ;check last Axis 5
+1 SET (YSGAFLN,YSGAFLD,YSGAFLC,YSGAFER)=""
+2 SET YSDXEL=$ORDER(^YSD(627.8,"AX5",DFN,-1))
+3 if YSDXEL<1
QUIT
+4 SET YSDXEN=$ORDER(^YSD(627.8,"AX5",DFN,YSDXEL,-1))
+5 if YSDXEN<1
QUIT
+6 SET YSDXEG=$GET(^YSD(627.8,YSDXEN,0))
+7 SET YSGAFLD=$PIECE(YSDXEG,U,3)
SET YSGAFLC=$PIECE(YSDXEG,U,4)
+8 SET YSDXEG=$GET(^YSD(627.8,YSDXEN,60))
+9 SET YSGAFLN=$PIECE(YSDXEG,U,3)
+10 SET YSGAFER=$GET(^YSD(627.8,YSDXEN,80,1,0))
+11 QUIT
PRINT ;
+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 SET YSDAYS=90
+3 DO ONELOC^YSGAF1
if YSCLIN=""
QUIT
+4 DO DATE^YSGAF1
if YSDATE<1
QUIT
+5 DO ONLYREQ^YSGAF1
if YSONLY=""
QUIT
+6 ;ASK DEVICE
+7 SET %ZIS="QM"
+8 DO ^%ZIS
+9 if $GET(POP)
QUIT
+10 IF $DATA(IO("Q"))
Begin DoDot:1
+11 NEW ZTRTN,ZTDESC,ZTSAVE
+12 SET ZTRTN="QPRT^YSGAF"
+13 SET ZTDESC="YSGAF PRINT"
+14 FOR ZZ="YSONLY","YSDAYS","YSCLIN","YSCNAME","YSDATE"
SET ZTSAVE(ZZ)=""
+15 DO ^%ZTLOAD
+16 DO HOME^%ZIS
+17 QUIT
End DoDot:1
QUIT
+18 USE IO
QPRT ;Queued Task Entry Point
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 DO LP1^YSGAF1
+3 SET YSPAGE=0
DO TOP
+4 IF '$DATA(^TMP("YSGAF",$JOB))
WRITE !,"No appointments found"
QUIT
PR1 SET YSN=""
SET YSOUT=1
FOR
SET YSN=$ORDER(^TMP("YSGAF",$JOB,"A",YSN))
if YSN=""
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^TMP("YSGAF",$JOB,"A",YSN,DFN))
if DFN'>0
QUIT
Begin DoDot:1
+1 DO CK
DO RULE
+2 if ('YSRULE)&(YSONLY)
QUIT
+3 DO DEM^VADPT
+4 WRITE !,$EXTRACT(YSN,1,25),?26,VA("BID"),?32,$SELECT($LENGTH(YSGAFER):"Er",YSGAFLN:YSGAFLN,1:"--")," ",$SELECT(YSGAFLD:$$FMTE^XLFDT(YSGAFLD,"5ZD"),1:" ")
+5 WRITE " "_$SELECT(YSRULE:"**",1:" ")_"______ __________________"
End DoDot:1
if $Y+4>IOSL
DO BOT
if YSOUT<1
QUIT
+6 DO ^%ZISC
+7 QUIT
TOP ;print header
+1 SET YSPAGE=YSPAGE+1
+2 IF '$DATA(YSLINE)
SET YSLINE=""
SET $PIECE(YSLINE,"-",79)=""
+3 WRITE @IOF,"GAF List Clinic: ",YSCNAME," **= > than ",YSDAYS," days"
+4 WRITE !,"Appointment Date: ",$$FMTE^XLFDT(YSDATE,"5ZD")
+5 WRITE ?32,"Last GAF New",?65,"page: ",YSPAGE
+6 WRITE !?32,"GAF Date GAF Clinician",!,YSLINE
+7 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
PTENT ;patient entry
+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,YSGAFER
+2 WRITE @IOF,"Global Assessment of functioning"
+3 FOR
KILL DFN
WRITE !
DO ^YSLRP
if '$DATA(DFN)
QUIT
DO DISP5
DO ADD5
+4 QUIT
DISP5 ;display last axis5
+1 if '$DATA(DFN)
QUIT
+2 DO DEM^VADPT
+3 WRITE !,VADM(1),?35,"SSN: xxx-xx-",VA("BID"),?55,"DOB: ",$PIECE(VADM(3),U,2)
DISP51 DO CK
+1 IF YSGAFLN
Begin DoDot:1
+2 WRITE !?4,"Last GAF: ",YSGAFLN," on: "
+3 SET Y=YSGAFLD
XECUTE ^DD("DD")
WRITE Y
+4 WRITE " by: ",$SELECT(+$GET(YSGAFLC):$PIECE(^VA(200,YSGAFLC,0),U),1:"--> No provider entered for this GAF score")
+5 IF $LENGTH(YSGAFER)>1
WRITE !,YSGAFER
End DoDot:1
+6 IF YSGAFLN<1
WRITE !?4,"no previous GAF"
+7 QUIT
ADD5 ;add axis 5 dx
+1 WRITE !!
+2 KILL DIR
SET DIR(0)="N^1:100:0"
SET DIR("A")="GAF Score"
SET DIR("?")="Enter the Global Assessment of Functioning : 1 to 100"
SET DIR("??")="YS-GAF SCALE"
+3 ;I $D(YSGAFLN) S:YSGAFLN?1N.N DIR("B")=YSGAFLN
+4 DO ^DIR
SET YSGN=Y
if X?1"^^".E
SET YSOUT=1
+5 IF $DATA(DIRUT)
WRITE !,"No GAF will be entered. Enter ^^ to end loop.",$CHAR(7)
QUIT
+6 KILL DIR
SET DIR(0)="DA^2961001:NOW:TX"
SET DIR("A")="Diagnosis date/time: "
SET DIR("B")="NOW"
+7 DO ^DIR
if Y>0
SET YSGD=Y
+8 IF $DATA(DIRUT)
WRITE !,"No GAF will be entered",$CHAR(7)
QUIT
+9 KILL DIR,DIC
SET DIC="^VA(200,"
SET DIC(0)="AEM"
SET DIC("A")="Assessing Clinician: "
SET DIC("B")=$PIECE(^VA(200,DUZ,0),U)
+10 DO ^DIC
KILL DIC
if Y>0
SET YSGC=+Y
+11 IF Y<1
WRITE !,"No GAF will be entered",$CHAR(7)
QUIT
+12 KILL DD,DO,DA,DINUM
+13 SET X="NOW"
SET %DT="TR"
DO ^%DT
SET X=Y
+14 SET DIC="^YSD(627.8,"
SET DIC(0)="L"
SET DLAYGO=627.8
DO FILE^DICN
if Y'>0
QUIT
SET YSDA=+Y
+15 DO PATSTAT^YSDX3B
+16 SET DIE="^YSD(627.8,"
SET DA=YSDA
SET DR=".02////"_DFN_";.03////"_YSGD_";.04////"_YSGC_";.05////"_DUZ_";65////"_YSGN_";66////"_YSSTAT
+17 LOCK +^YSD(627.8,YSDA):9999
if '$TEST
QUIT
+18 DO ^DIE
+19 LOCK -^YSD(627.8,YSDA)
+20 DO EN^YSGAFOBX(YSDA)
+21 QUIT
+22 ;
RET(YSX) ;This extrinsic returns the most recent GAF score, GAF
+1 ;diagnosis date and physician/provider performing the diagnosis,
+2 ;for the internal entry number given (via variable YSX.) If no
+3 ;GAF score data is on file for this internal entry number, -1 is
+4 ;returned.
+5 NEW YSHOLD
+6 SET (YSHOLD)=""
+7 SET YSHOLD=$ORDER(^YSD(627.8,"C",YSX,""),-1)
+8 IF YSHOLD
Begin DoDot:1
+9 SET YSZ=$PIECE($GET(^YSD(627.8,YSHOLD,60)),"^",3)
+10 SET YSZ=YSZ_"^"_$PIECE($GET(^YSD(627.8,YSHOLD,0)),"^",3)
+11 SET YSZ=YSZ_"^"_$PIECE($GET(^YSD(627.8,YSHOLD,0)),"^",4)
End DoDot:1
+12 IF '$TEST
SET YSZ=-1
+13 QUIT YSZ
+14 ;
UPD(YSPN,YSGN,YSGD,YSGC,YSPT) ;Update GAF information
+1 ; YSPN - Patient Name
+2 ; YSGN - GAF Score (Axis 5)
+3 ; YSGD - Date/Time of Diagnosis
+4 ; YSGC - Diagnosis By
+5 ; YSPT - Patient Type ('I'npatient or 'O'utpatient)
+6 SET YSERR=0
+7 IF '$GET(YSPN)
Begin DoDot:1
+8 WRITE !," The Patient IEN is required!!!",!
+9 SET YSERR=1
+10 QUIT
End DoDot:1
+11 ;
+12 IF '$GET(YSGN)
Begin DoDot:1
+13 WRITE !," The GAF Score is required!!!",!
+14 SET YSERR=1
+15 QUIT
End DoDot:1
+16 ;
+17 IF '$GET(YSGD)
Begin DoDot:1
+18 WRITE " The Observation Date/Time is required!!!",!
+19 SET YSERR=1
+20 QUIT
End DoDot:1
+21 ;
+22 IF '$GET(YSGC)
Begin DoDot:1
+23 WRITE " The Provider is required!!!",!
+24 SET YSERR=1
+25 QUIT
End DoDot:1
+26 ;
+27 ;---->
if YSERR
QUIT
+28 ;
+29 KILL DD,DO,DA,DINUM
+30 SET DLAYGO=627.8
SET X="NOW"
SET %DT="TR"
DO ^%DT
SET X=Y
+31 SET DIC="^YSD(627.8,"
SET DIC(0)="L"
+32 DO FILE^DICN
if Y'>0
QUIT
SET YSDA=+Y
+33 SET DFN=+YSPN
+34 DO PATSTAT^YSDX3B
+35 SET DIE="^YSD(627.8,"
SET DA=YSDA
+36 SET DR=".02////"_YSPN_";.03////"_YSGD_";.04////"_YSGC_";.05////"_DUZ
+37 SET DR=DR_";65////"_YSGN_";66////"_YSSTAT
+38 LOCK +^YSD(627.8,YSDA):9999
if '$TEST
QUIT
+39 DO ^DIE
+40 LOCK -^YSD(627.8,YSDA)
+41 DO EN^YSGAFOBX(YSDA)
+42 KILL %DT,DA,DIC,DIE,DLAYGO,DR,X,Y,YSDA,YSPN,YSGN,YSGD,YSGC,YSSTAT
+43 QUIT
