IBDF18E4 ;ALB/DHH - ENCOUNTER FORM - MISC INTERFACES utilities ;19-JUN-01
;;3.0;AUTOMATED INFO COLLECTION SYS;**37,72**;APR 24, 1997;Build 1
;
;-- this routine is to be called after PXCA is called in order to
; send additional information to other packages that PCE does not
; send to currently
;
Q ;IBD*3*72 removes GAF functionality from AICS
GAF ;send GAF information to Mental Health
;
;-- GAF information is filed with Mental Health only if the following
; variables are set
; -- DFN = Patient IEN
; SCORE = GAF Score
; PROV = Provider holding SD GAF SCORE security key
; DATE = Encounter Date/Time
; VISIT = Inpatient or Outpatient Visit
;
Q ;IBD*3*72 removes GAF functionality from AICS
N DIG1,DIG2,DIG3,EPROV,SCORE,PROV,DATE,VISIT,X,DFN
S (SCORE,PROV,DATE,VISIT)=""
;
; --if pxca (ibd gaf score col 3) exist the there should be 3
; columns present to make the 3 character number
;
I $D(PXCA("IBD GAF SCORE COL 3")) D
. ;
. S (DIG1,DIG2,DIG3)=""
. ;
. ; checking to see if column 3 is existing
. ; column 1 and 2 are not required to make score
. ;
. Q:'$D(PXCA("IBD GAF SCORE COL 3"))
. S EPROV="" F S EPROV=$O(PXCA("IBD GAF SCORE COL 3",EPROV)) Q:EPROV="" D
.. ;
.. S DIG1=$P($G(PXCA("IBD GAF SCORE COL 1",EPROV,+$O(PXCA("IBD GAF SCORE COL 1",EPROV,0)))),"^",1)
.. S DIG2=$P($G(PXCA("IBD GAF SCORE COL 2",EPROV,+$O(PXCA("IBD GAF SCORE COL 2",EPROV,0)))),"^",1)
.. S DIG3=$P($G(PXCA("IBD GAF SCORE COL 3",EPROV,+$O(PXCA("IBD GAF SCORE COL 3",EPROV,0)))),"^",1)
.. S SCORE=DIG1_DIG2_DIG3
.. ;
.. ; -- score is required to be 1-100
.. ;
.. I SCORE>100 S SCORE=""
.. S PXCA("IBD GAF SCORE COL 1",EPROV,1)=SCORE
.. ;
I $D(PXCA("IBD GAF SCORE COL 1")) D
. S EPROV="" F S EPROV=$O(PXCA("IBD GAF SCORE COL 1",EPROV)) Q:EPROV="" D
.. S SCORE=$P($G(PXCA("IBD GAF SCORE COL 1",EPROV,+$O(PXCA("IBD GAF SCORE COL 1",EPROV,0)))),"^")
.. S PROV=$P($G(PXCA("IBD GAF SCORE PROVIDER",EPROV,+$O(PXCA("IBD GAF SCORE PROVIDER",EPROV,0)))),"^")
.. S DFN=$P($G(PXCA("ENCOUNTER")),"^",2)
.. S DATE=$P($G(PXCA("ENCOUNTER")),"^",14)
.. S VISIT=$S($P($G(PXCA("ENCOUNTER")),"^",3)="W":"I",1:"O")
.. ;
.. ; do error check and file error quit if error
.. ; -- if any mandated information is missing file an error
.. ; in AICS' error log.
.. ;
.. I DFN="" D LOGERR^IBDF18E2(3570005,.FORMID) Q
.. I SCORE>100!(SCORE<1) D LOGERR^IBDF18E2(3570005,.FORMID) Q
.. I DATE="" D LOGERR^IBDF18E2(3570005,.FORMID) Q
.. I PROV="" D LOGERR^IBDF18E2(3570005,.FORMID) Q
.. I VISIT="" D LOGERR^IBDF18E2(3570005,.FORMID) Q
.. D UPD^YSGAF(DFN,SCORE,DATE,PROV,VISIT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF18E4 2722 printed Sep 23, 2025@20:27:03 Page 2
IBDF18E4 ;ALB/DHH - ENCOUNTER FORM - MISC INTERFACES utilities ;19-JUN-01
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**37,72**;APR 24, 1997;Build 1
+2 ;
+3 ;-- this routine is to be called after PXCA is called in order to
+4 ; send additional information to other packages that PCE does not
+5 ; send to currently
+6 ;
+7 ;IBD*3*72 removes GAF functionality from AICS
QUIT
GAF ;send GAF information to Mental Health
+1 ;
+2 ;-- GAF information is filed with Mental Health only if the following
+3 ; variables are set
+4 ; -- DFN = Patient IEN
+5 ; SCORE = GAF Score
+6 ; PROV = Provider holding SD GAF SCORE security key
+7 ; DATE = Encounter Date/Time
+8 ; VISIT = Inpatient or Outpatient Visit
+9 ;
+10 ;IBD*3*72 removes GAF functionality from AICS
QUIT
+11 NEW DIG1,DIG2,DIG3,EPROV,SCORE,PROV,DATE,VISIT,X,DFN
+12 SET (SCORE,PROV,DATE,VISIT)=""
+13 ;
+14 ; --if pxca (ibd gaf score col 3) exist the there should be 3
+15 ; columns present to make the 3 character number
+16 ;
+17 IF $DATA(PXCA("IBD GAF SCORE COL 3"))
Begin DoDot:1
+18 ;
+19 SET (DIG1,DIG2,DIG3)=""
+20 ;
+21 ; checking to see if column 3 is existing
+22 ; column 1 and 2 are not required to make score
+23 ;
+24 if '$DATA(PXCA("IBD GAF SCORE COL 3"))
QUIT
+25 SET EPROV=""
FOR
SET EPROV=$ORDER(PXCA("IBD GAF SCORE COL 3",EPROV))
if EPROV=""
QUIT
Begin DoDot:2
+26 ;
+27 SET DIG1=$PIECE($GET(PXCA("IBD GAF SCORE COL 1",EPROV,+$ORDER(PXCA("IBD GAF SCORE COL 1",EPROV,0)))),"^",1)
+28 SET DIG2=$PIECE($GET(PXCA("IBD GAF SCORE COL 2",EPROV,+$ORDER(PXCA("IBD GAF SCORE COL 2",EPROV,0)))),"^",1)
+29 SET DIG3=$PIECE($GET(PXCA("IBD GAF SCORE COL 3",EPROV,+$ORDER(PXCA("IBD GAF SCORE COL 3",EPROV,0)))),"^",1)
+30 SET SCORE=DIG1_DIG2_DIG3
+31 ;
+32 ; -- score is required to be 1-100
+33 ;
+34 IF SCORE>100
SET SCORE=""
+35 SET PXCA("IBD GAF SCORE COL 1",EPROV,1)=SCORE
+36 ;
End DoDot:2
End DoDot:1
+37 IF $DATA(PXCA("IBD GAF SCORE COL 1"))
Begin DoDot:1
+38 SET EPROV=""
FOR
SET EPROV=$ORDER(PXCA("IBD GAF SCORE COL 1",EPROV))
if EPROV=""
QUIT
Begin DoDot:2
+39 SET SCORE=$PIECE($GET(PXCA("IBD GAF SCORE COL 1",EPROV,+$ORDER(PXCA("IBD GAF SCORE COL 1",EPROV,0)))),"^")
+40 SET PROV=$PIECE($GET(PXCA("IBD GAF SCORE PROVIDER",EPROV,+$ORDER(PXCA("IBD GAF SCORE PROVIDER",EPROV,0)))),"^")
+41 SET DFN=$PIECE($GET(PXCA("ENCOUNTER")),"^",2)
+42 SET DATE=$PIECE($GET(PXCA("ENCOUNTER")),"^",14)
+43 SET VISIT=$SELECT($PIECE($GET(PXCA("ENCOUNTER")),"^",3)="W":"I",1:"O")
+44 ;
+45 ; do error check and file error quit if error
+46 ; -- if any mandated information is missing file an error
+47 ; in AICS' error log.
+48 ;
+49 IF DFN=""
DO LOGERR^IBDF18E2(3570005,.FORMID)
QUIT
+50 IF SCORE>100!(SCORE<1)
DO LOGERR^IBDF18E2(3570005,.FORMID)
QUIT
+51 IF DATE=""
DO LOGERR^IBDF18E2(3570005,.FORMID)
QUIT
+52 IF PROV=""
DO LOGERR^IBDF18E2(3570005,.FORMID)
QUIT
+53 IF VISIT=""
DO LOGERR^IBDF18E2(3570005,.FORMID)
QUIT
+54 DO UPD^YSGAF(DFN,SCORE,DATE,PROV,VISIT)
End DoDot:2
End DoDot:1
+55 QUIT
