IBDFN16 ;ALB/DHH - ENCOUNTER FORM - (entry points for gaf project) ;3/20/2001
;;3.0;AUTOMATED INFO COLLECTION SYS;**37**;APR 24, 1997
;
GAFPROV ;Enter GAF Score Provider
;
; -- @IBARY should be defined
;
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 ($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
;
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
;
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 1249 printed Nov 22, 2024@18:03:04 Page 2
IBDFN16 ;ALB/DHH - ENCOUNTER FORM - (entry points for gaf project) ;3/20/2001
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**37**;APR 24, 1997
+2 ;
GAFPROV ;Enter GAF Score Provider
+1 ;
+2 ; -- @IBARY should be defined
+3 ;
+4 NEW DIC,Y,DIROUT,DIRUT,DTOUT,DUOUT
+5 SET DIC=200
SET DIC(0)="AEQM"
+6 SET DIC("S")="I $$OKPROV^IBDFDE23(Y)"
+7 SET DIC("A")="Provider determining GAF Score: "
DO ^DIC
KILL DIC
+8 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
QUIT
+9 IF Y<0
QUIT
+10 SET @IBARY=Y
+11 QUIT
+12 ;
OKPROV(IEN) ; Screen for provider lookup using person class
+1 ; provider for gaf must have the sd gaf score security key
+2 ;
+3 QUIT ($DATA(^XUSEC("SD GAF SCORE",IEN)))
+4 ;
GAFRET ;Previous GAF information returned from Mental Health
+1 ;
+2 ; -- this is to be used by PREVIOUS GAF SCORE package interface
+3 ;
+4 NEW GAFDAT,Y,GAFPROV,X,X1,X2,IBX
+5 SET IBX=$$RET^YSGAF($GET(DFN))
+6 IF +IBX=-1
SET @IBARY=""
QUIT
+7 SET GAFDAT=$PIECE(IBX,"^",2)
+8 SET Y=GAFDAT
KILL %DT
DO DD^%DT
SET $PIECE(IBX,"^",2)=$PIECE(Y,"@")
+9 SET GAFPROV=$PIECE($GET(^VA(200,+$PIECE(IBX,"^",3),0)),"^")
+10 SET $PIECE(IBX,"^",3)=GAFPROV
+11 SET $PIECE(IBX,"^",4)=$$RULE(GAFDAT)
+12 SET @IBARY=IBX
+13 QUIT
RULE(GAFDAT) ;check for greater than 90 days
+1 ;
+2 ; -- gafdat is the internal date of the last gaf score
+3 ;
+4 NEW RULE
+5 SET RULE="NO"
+6 SET X1=DT
SET X2=GAFDAT
DO ^%DTC
+7 if X>90
SET RULE="YES"
+8 QUIT RULE
