IBDFN16.m

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 ---IBDFN16   1249     printed  Apr 23, 2025@19:07:22                                                                                                                                                                                                     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