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

DGPTSCAN.m

Go to the documentation of this file. 
  1. DGPTSCAN ;ALB/MTC - SPECIAL ACTION SCAN PROCESS ; 1 MAR 91
  1.  ;;5.3;Registration;**29,64,114,189,729,1015**;Aug 13, 1993;Build 21
  1.  ;;MAS 5.1
  1. CHK501 ;--
  1.  D INIT G ENQ:DGOUT
  1.  G ENQ:'$D(^DGPT(DGPTF,"M",+DGMOV,0)) S DGREC=^(0)
  1.  F DGI=5:1:9 I $P(DGREC,U,DGI) S DGPTIT($P(DGREC,U,DGI)_";ICD9(")=""
  1.  S DGHOLD=$S($D(^DGPT(DGPTF,"M",+DGMOV,300)):^(300),1:"")
  1.  D SCAN
  1.  I '$D(DGBPC),DGHOLD']"" G CHK5Q
  1.  S DIE="^DGPT(",DA=DGPTF,DR="[DGPT 501 CLEANUP]"
  1.  D ^DIE
  1.  ;;
  1.  ;;ADDED FOR GAF ENHANCEMENT 6/2/98
  1.  ;;Gathers GAF Score, GAF Date, GAF Provider and sends to
  1.  ;;Mental Health package
  1.  N DGGAFSC,DGGAFDT,DGGAFPR,DGDFN
  1.  S DGGAFSC=$P(DGHOLD,"^",6),DGDFN=$P(^DGPT(DGPTF,0),"^")
  1.  S DGGAFDT=$P(^DGPT(DGPTF,0),"^",2)\1
  1.  S DGGAFPR=$P($G(^DGPT(DGPTF,"M",+DGMOV,"P")),"^",5) ;Provider
  1.  D UPD^YSGAF(DGDFN,DGGAFSC,DGGAFDT,DGGAFPR,"I")
  1.  ;;END GAF ENHANCEMENTS
  1.  ;;
  1. CHK5Q K DA,DR,DGHOLD,DGBPC,DGPTIT,DIE,DGREC,DGI,DGSCDT,DGSTART,DGTREC,DGOUT
  1.  Q
  1.  ;
  1. CHK601 ;--
  1.  D INIT G ENQ:DGOUT
  1.  G ENQ:'$D(^DGPT(DGPTF,"P",+P(DGZP,1),0)) S DGREC=^(0)
  1.  F DGI=5:1:9 I $P(DGREC,U,DGI) S DGPTIT($P(DGREC,U,DGI)_";ICD0(")=""
  1.  S DGHOLD=DGREC
  1.  D SCAN
  1.  I '$D(DGBPC(8)),$P(DGHOLD,U,4)']"" G CHK6Q
  1.  S DIE="^DGPT(",DA=DGPTF,DR="[DGPT 601 CLEANUP]"
  1.  D ^DIE
  1. CHK6Q K DA,DR,DGHOLD,DGBPC,DGPTIT,DIE,DGREC,DGI,DGOUT
  1.  Q
  1. CHK401 ;-- 
  1.  D INIT G ENQ:DGOUT
  1.  G ENQ:'$D(^DGPT(DGPTF,"S",+DGSUR,0)) S DGREC=^(0)
  1.  F DGI=8:1:12 I $P(DGREC,U,DGI) S DGPTIT($P(DGREC,U,DGI)_";ICD0(")=""
  1.  S DGHOLD=$S($D(^DGPT(DGPTF,"S",+DGSUR,300)):^(300),1:"")
  1.  D SCAN
  1.  I '$D(DGBPC),DGHOLD']"" G CHK4Q
  1.  S DIE="^DGPT(",DA=DGPTF,DR="[DGPT 401 CLEANUP]"
  1.  D ^DIE
  1. CHK4Q K DA,DR,DGHOLD,DGBPC,DGPTIT,DIE,DGREC,DGI,DGSCDT,DGSTART,DGTREC,DGOUT
  1.  Q
  1.  ;
  1. CHK701 ;-- will get data from flagchk then stuff into 701 (300 node)
  1.  G CHK7Q:'$D(^DGPT(DGPTF,70)) S DGREC=^(70)
  1.  F DGI=10,16:1:24 I $P(DGREC,U,DGI) S DGPTIT($P(DGREC,U,DGI)_";ICD9(")=""
  1.  D DC,SCAN,ANYPSY,FLAGCHK
  1.  S DGREC=$S($D(^DGPT(DGPTF,300)):^(300),1:""),DR="",DA=DGPTF,DIE="^DGPT("
  1.  D GETNUM
  1.  F DGII=2:1:DGFNUM S DR=DR_$S($P(DG701,U,DGII)]""&($P(DG701,U,DGII)'=$P(DGREC,U,DGII)):"300.0"_DGII_"////"_$P(DG701,U,DGII)_";",'$D(DGBPC(DGII))&($P(DGREC,U,DGII)]"")&($P(DG701,U,DGII)']""):"300.0"_DGII_"////@;",1:"")
  1. CHK7J I DR]"" D ^DIE
  1. CHK7Q ;
  1.  K DGII,DA,DR,DIE,DG701,DGI,DGT,DGREC,DGFNUM,DGSCDT,DGSTART,DGTREC,DGOUT
  1.  Q
  1. FLAGCHK ;-- build 701 from 501 responses, kill flags if necessary
  1.  S DG701="",DGOUT=0
  1.  F DGI=0:0 S DGI=$O(^DGPT(DGPTF,"M","AM",DGI)) Q:DGI'>0  F DGJ=0:0 S DGJ=$O(^DGPT(DGPTF,"M","AM",DGI,DGJ)) Q:DGJ'>0  I $D(^DGPT(DGPTF,"M",DGJ,300)) S DGHOLD=^(300) D FL1
  1.  S DGNDIS=$S('$D(^DGPT(DGPTF,70)):0,1:+^(70))
  1.  I DGNDIS'>0,$D(^DGPT(DGPTF,"M",1,300)) S DGHOLD=^(300) D FL1
  1. FLAGQ K DGI,DGNDIS
  1.  Q
  1. FL1 ;
  1.  D GETNUM
  1.  F DGII=2:1:DGFNUM I $P(DGHOLD,U,DGII)]"",$P(DG701,U,DGII)']"" S $P(DG701,U,DGII)=$P(DGHOLD,U,DGII) K DGBPC(DGII)
  1. FL1Q K DGII,DGHOLD,DGK,DGFNUM
  1.  Q
  1.  ;
  1. SCAN ;-- process DGPTIT array
  1.  K DGBPC
  1.  D ISPSY
  1.  G:'$D(DGPTIT) SCANQ
  1.  D DC ;return discharge date or current date in DGSCDT
  1.  S DGI="" F DGJ=0:0 S DGI=$O(DGPTIT(DGI)) Q:DGI=""  F DGK=0:0 S DGK=$O(^DIC(45.89,"ASPL",DGI,DGK)) Q:'DGK  D S1
  1. SCANQ ;
  1.  K DGSPEC,DGI,DGJ,DGK
  1.  Q
  1.  ;
  1. S1 ;-- check inactive dates, set flag array
  1.  G S1Q:'$D(^DIC(45.89,DGK,0)) S X=^(0)
  1.  I $P(X,U,3)]"",$D(DGSCDT) G S1Q:DGSCDT>$P(X,U,3)
  1.  S Y=+X
  1.  G S1Q:'$D(^DIC(45.88,Y,0)) S X=^(0)
  1.  I $P(X,U,3)]"",$D(DGSCDT) G S1Q:DGSCDT>$P(X,U,3)
  1.  I $P(X,U,2)]"" S X=$P(X,U,2) F DGII=1:1 S Y=$P(X,",",DGII) Q:'Y  D FLGFIL
  1. S1Q ;
  1.  K X,Y,DGII
  1.  Q
  1.  ;
  1. DC ;-- find discharge date
  1.  S DGSCDT=$S('$D(^DGPT(PTF,70)):DT,^(70):+^(70),1:DT)
  1.  Q
  1.  ;
  1. ENQ ;
  1.  K DG701,DGSTART,DGI,DGOUT,DGREC,DGBPC,DGPTIT,DGTREC,DGSCDT
  1.  Q
  1.  ;
  1. GETNUM ;-- returns the number of additional questions/flags
  1.  S DGFNUM=7
  1.  Q
  1.  ;
  1. INIT ;-- init routine
  1.  S DGOUT=0,(DGTREC,DGHOLD)=""
  1.  ;-- DGSTART should be set to 2910930 for national release
  1.  S DGSTART=2910930
  1.  D DC
  1.  D LO^DGUTL,HOME^%ZIS
  1.  K DGPTIT
  1. INITQ ;
  1.  Q
  1.  ;
  1. ANYPSY ;-- will go through all movements check for PSYCH specialty
  1.  N DGMOV
  1.  K DGPSY
  1.  I '$D(^DGPT(DGPTF,"M")) G ANYQ
  1.  F DGMOV=0:0 S DGMOV=$O(^DGPT(DGPTF,"M",DGMOV)) Q:'DGMOV  D ISPSY I $D(DGSPEC) S DGPSY=""
  1.  I '$D(DGPSY) K DGBPC(5),DGBPC(6),DGBPC(7)
  1. ANYQ ;
  1.  K DGSPEC
  1.  Q
  1. ISPSY ;-- check if losing specialty is in psych range set flag.
  1.  ;-- if psych then $D(DGSPEC)
  1.  K DGSPEC
  1.  I '$D(DGMOV) S DGSPEC="" G ISPSYQ
  1.  I $D(DGMOV) S DGSPEC=$P(^DGPT(DGPTF,"M",DGMOV,0),U,2) I '$P($G(^DIC(42.4,+DGSPEC,0)),U,4) K DGSPEC
  1. ISPSYQ Q
  1.  ;
  1. FLGFIL ;-- fill DGBPC with correct flag.
  1.  I '$D(DGSPEC),Y>4,Y<8 G FLGFILQ
  1.  S DGBPC(Y)=""
  1. FLGFILQ ;
  1.  Q
  1.  ;
  1. ANYSC(PTF) ;-- will go through all movements check for sc treatment
  1.  ;  INPUT - ptf record ien to check
  1.  ;  OUTPUT- 1 sc treatment, 0 no sc treatment
  1.  N DGMOV,RESULT
  1.  S RESULT=0
  1.  I '$D(^DGPT(PTF,"M")) G ANYSCQ
  1.  S DGMOV=0 F  S DGMOV=$O(^DGPT(PTF,"M",DGMOV)) Q:'DGMOV  I $P(^(DGMOV,0),U,18)=1 S RESULT=1 Q
  1. ANYSCQ ;
  1.  Q RESULT
  1.  ;