Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDF18E4

IBDF18E4.m

Go to the documentation of this file.
  1. IBDF18E4 ;ALB/DHH - ENCOUNTER FORM - MISC INTERFACES utilities ;19-JUN-01
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;**37**;APR 24, 1997
  1. ;
  1. ;-- this routine is to be called after PXCA is called in order to
  1. ; send additional information to other packages that PCE does not
  1. ; send to currently
  1. ;
  1. GAF ;send GAF information to Mental Health
  1. ;
  1. ;-- GAF information is filed with Mental Health only if the following
  1. ; variables are set
  1. ; -- DFN = Patient IEN
  1. ; SCORE = GAF Score
  1. ; PROV = Provider holding SD GAF SCORE security key
  1. ; DATE = Encounter Date/Time
  1. ; VISIT = Inpatient or Outpatient Visit
  1. ;
  1. N DIG1,DIG2,DIG3,EPROV,SCORE,PROV,DATE,VISIT,X,DFN
  1. S (SCORE,PROV,DATE,VISIT)=""
  1. ;
  1. ; --if pxca (ibd gaf score col 3) exist the there should be 3
  1. ; columns present to make the 3 character number
  1. ;
  1. I $D(PXCA("IBD GAF SCORE COL 3")) D
  1. . ;
  1. . S (DIG1,DIG2,DIG3)=""
  1. . ;
  1. . ; checking to see if column 3 is existing
  1. . ; column 1 and 2 are not required to make score
  1. . ;
  1. . Q:'$D(PXCA("IBD GAF SCORE COL 3"))
  1. . S EPROV="" F S EPROV=$O(PXCA("IBD GAF SCORE COL 3",EPROV)) Q:EPROV="" D
  1. .. ;
  1. .. S DIG1=$P($G(PXCA("IBD GAF SCORE COL 1",EPROV,+$O(PXCA("IBD GAF SCORE COL 1",EPROV,0)))),"^",1)
  1. .. S DIG2=$P($G(PXCA("IBD GAF SCORE COL 2",EPROV,+$O(PXCA("IBD GAF SCORE COL 2",EPROV,0)))),"^",1)
  1. .. S DIG3=$P($G(PXCA("IBD GAF SCORE COL 3",EPROV,+$O(PXCA("IBD GAF SCORE COL 3",EPROV,0)))),"^",1)
  1. .. S SCORE=DIG1_DIG2_DIG3
  1. .. ;
  1. .. ; -- score is required to be 1-100
  1. .. ;
  1. .. I SCORE>100 S SCORE=""
  1. .. S PXCA("IBD GAF SCORE COL 1",EPROV,1)=SCORE
  1. .. ;
  1. I $D(PXCA("IBD GAF SCORE COL 1")) D
  1. . S EPROV="" F S EPROV=$O(PXCA("IBD GAF SCORE COL 1",EPROV)) Q:EPROV="" D
  1. .. S SCORE=$P($G(PXCA("IBD GAF SCORE COL 1",EPROV,+$O(PXCA("IBD GAF SCORE COL 1",EPROV,0)))),"^")
  1. .. S PROV=$P($G(PXCA("IBD GAF SCORE PROVIDER",EPROV,+$O(PXCA("IBD GAF SCORE PROVIDER",EPROV,0)))),"^")
  1. .. S DFN=$P($G(PXCA("ENCOUNTER")),"^",2)
  1. .. S DATE=$P($G(PXCA("ENCOUNTER")),"^",14)
  1. .. S VISIT=$S($P($G(PXCA("ENCOUNTER")),"^",3)="W":"I",1:"O")
  1. .. ;
  1. .. ; do error check and file error quit if error
  1. .. ; -- if any mandated information is missing file an error
  1. .. ; in AICS' error log.
  1. .. ;
  1. .. I DFN="" D LOGERR^IBDF18E2(3570005,.FORMID) Q
  1. .. I SCORE>100!(SCORE<1) D LOGERR^IBDF18E2(3570005,.FORMID) Q
  1. .. I DATE="" D LOGERR^IBDF18E2(3570005,.FORMID) Q
  1. .. I PROV="" D LOGERR^IBDF18E2(3570005,.FORMID) Q
  1. .. I VISIT="" D LOGERR^IBDF18E2(3570005,.FORMID) Q
  1. .. D UPD^YSGAF(DFN,SCORE,DATE,PROV,VISIT)
  1. Q