IBDFN16 ;ALB/DHH - ENCOUNTER FORM - (entry points for gaf project) ;3/20/2001
;;3.0;AUTOMATED INFO COLLECTION SYS;**37,72**;APR 24, 1997;Build 1
;
Q ;IBD*3*72 removes GAF functionality from AICS
GAFPROV ;Enter GAF Score Provider
;
; -- @IBARY should be defined
;
Q ;IBD*3*72 removes GAF functionality from AICS
N DIC,Y,DIROUT,DIRUT,DTOUT,DUOUT
S DIC=200,DIC(0)="AEQM"
S DIC("S")="I $$OKPROV^IBDFDE23(Y)"
S DIC("A")="Provider determining GAF Score: " D ^DIC K DIC
I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) Q
I Y<0 Q
S @IBARY=Y
Q
;
OKPROV(IEN) ; Screen for provider lookup using person class
; provider for gaf must have the sd gaf score security key
;
Q ;IBD*3*72 removes GAF functionality from AICS
Q ($D(^XUSEC("SD GAF SCORE",IEN)))
;
GAFRET ;Previous GAF information returned from Mental Health
;
; -- this is to be used by PREVIOUS GAF SCORE package interface
;
Q ;IBD*3*72 removes GAF functionality from AICS
N GAFDAT,Y,GAFPROV,X,X1,X2,IBX
S IBX=$$RET^YSGAF($G(DFN))
I +IBX=-1 S @IBARY="" Q
S GAFDAT=$P(IBX,"^",2)
S Y=GAFDAT K %DT D DD^%DT S $P(IBX,"^",2)=$P(Y,"@")
S GAFPROV=$P($G(^VA(200,+$P(IBX,"^",3),0)),"^")
S $P(IBX,"^",3)=GAFPROV
S $P(IBX,"^",4)=$$RULE(GAFDAT)
S @IBARY=IBX
Q
RULE(GAFDAT) ;check for greater than 90 days
;
; -- gafdat is the internal date of the last gaf score
;
Q ;IBD*3*72 removes GAF functionality from AICS
N RULE
S RULE="NO"
S X1=DT,X2=GAFDAT D ^%DTC
S:X>90 RULE="YES"
Q RULE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFN16 1515 printed Aug 26, 2025@23:08:39 Page 2
IBDFN16 ;ALB/DHH - ENCOUNTER FORM - (entry points for gaf project) ;3/20/2001
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**37,72**;APR 24, 1997;Build 1
+2 ;
+3 ;IBD*3*72 removes GAF functionality from AICS
QUIT
GAFPROV ;Enter GAF Score Provider
+1 ;
+2 ; -- @IBARY should be defined
+3 ;
+4 ;IBD*3*72 removes GAF functionality from AICS
QUIT
+5 NEW DIC,Y,DIROUT,DIRUT,DTOUT,DUOUT
+6 SET DIC=200
SET DIC(0)="AEQM"
+7 SET DIC("S")="I $$OKPROV^IBDFDE23(Y)"
+8 SET DIC("A")="Provider determining GAF Score: "
DO ^DIC
KILL DIC
+9 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
QUIT
+10 IF Y<0
QUIT
+11 SET @IBARY=Y
+12 QUIT
+13 ;
OKPROV(IEN) ; Screen for provider lookup using person class
+1 ; provider for gaf must have the sd gaf score security key
+2 ;
+3 ;IBD*3*72 removes GAF functionality from AICS
QUIT
+4 QUIT ($DATA(^XUSEC("SD GAF SCORE",IEN)))
+5 ;
GAFRET ;Previous GAF information returned from Mental Health
+1 ;
+2 ; -- this is to be used by PREVIOUS GAF SCORE package interface
+3 ;
+4 ;IBD*3*72 removes GAF functionality from AICS
QUIT
+5 NEW GAFDAT,Y,GAFPROV,X,X1,X2,IBX
+6 SET IBX=$$RET^YSGAF($GET(DFN))
+7 IF +IBX=-1
SET @IBARY=""
QUIT
+8 SET GAFDAT=$PIECE(IBX,"^",2)
+9 SET Y=GAFDAT
KILL %DT
DO DD^%DT
SET $PIECE(IBX,"^",2)=$PIECE(Y,"@")
+10 SET GAFPROV=$PIECE($GET(^VA(200,+$PIECE(IBX,"^",3),0)),"^")
+11 SET $PIECE(IBX,"^",3)=GAFPROV
+12 SET $PIECE(IBX,"^",4)=$$RULE(GAFDAT)
+13 SET @IBARY=IBX
+14 QUIT
RULE(GAFDAT) ;check for greater than 90 days
+1 ;
+2 ; -- gafdat is the internal date of the last gaf score
+3 ;
+4 ;IBD*3*72 removes GAF functionality from AICS
QUIT
+5 NEW RULE
+6 SET RULE="NO"
+7 SET X1=DT
SET X2=GAFDAT
DO ^%DTC
+8 if X>90
SET RULE="YES"
+9 QUIT RULE
