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