- 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 Feb 18, 2025@23:40:47 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