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. ;