DGPTSCAN ;ALB/MTC,WOIFO/PMK - SPECIAL ACTION SCAN PROCESS ;03/26/2015 3:27 PM
;;5.3;Registration;**29,64,114,189,729,850,884**;Aug 13, 1993;Build 31
;;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(")=""
N DGD D PTFICD^DGPTFUT(501,DGPTF,+DGMOV,.DGD) G ENQ:$D(DGD)'=11
S DGI="" F S DGI=$O(DGD(DGI)) Q:DGI="" S DGPTIT($P(DGD(DGI),U)_";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(")=""
N DGD D PTFICD^DGPTFUT(601,DGPTF,+P(DGZP,1),.DGD) G ENQ:$D(DGD)'=11
S DGI="" F S DGI=$O(DGD(DGI)) Q:DGI="" S DGPTIT($P(DGD(DGI),U)_";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(")=""
N DGD D PTFICD^DGPTFUT(401,DGPTF,+DGSUR,.DGD) G ENQ:$D(DGD)'=11
S DGI="" F S DGI=$O(DGD(DGI)) Q:DGI="" S DGPTIT($P(DGD(DGI),U)_";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(")=""
N DGD D PTFICD^DGPTFUT(701,DGPTF,,.DGD) G ENQ:$D(DGD)'=11
S DGI="" F S DGI=$O(DGD(DGI)) Q:DGI="" S DGPTIT($P(DGD(DGI),U)_";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
; -- 850 Fix (BELOW), problem in fee basis when DGMOV is defined but no global ref.
I $D(DGMOV) D
. S DGSPEC=$P($G(^DGPT(DGPTF,"M",+$G(DGMOV),0)),U,2)
. I '$P($G(^DIC(42.4,+$G(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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTSCAN 5663 printed Sep 23, 2025@20:29:29 Page 2
DGPTSCAN ;ALB/MTC,WOIFO/PMK - SPECIAL ACTION SCAN PROCESS ;03/26/2015 3:27 PM
+1 ;;5.3;Registration;**29,64,114,189,729,850,884**;Aug 13, 1993;Build 31
+2 ;;MAS 5.1
CHK501 ;--
+1 DO INIT
if DGOUT
GOTO ENQ
+2 ; G ENQ:'$D(^DGPT(DGPTF,"M",+DGMOV,0)) S DGREC=^(0)
+3 ; F DGI=5:1:9 I $P(DGREC,U,DGI) S DGPTIT($P(DGREC,U,DGI)_";ICD9(")=""
+4 NEW DGD
DO PTFICD^DGPTFUT(501,DGPTF,+DGMOV,.DGD)
if $DATA(DGD)'=11
GOTO ENQ
+5 SET DGI=""
FOR
SET DGI=$ORDER(DGD(DGI))
if DGI=""
QUIT
SET DGPTIT($PIECE(DGD(DGI),U)_";ICD9(")=""
+6 SET DGHOLD=$SELECT($DATA(^DGPT(DGPTF,"M",+DGMOV,300)):^(300),1:"")
+7 DO SCAN
+8 IF '$DATA(DGBPC)
IF DGHOLD']""
GOTO CHK5Q
+9 SET DIE="^DGPT("
SET DA=DGPTF
SET DR="[DGPT 501 CLEANUP]"
+10 DO ^DIE
+11 ;;
+12 ;;ADDED FOR GAF ENHANCEMENT 6/2/98
+13 ;;Gathers GAF Score, GAF Date, GAF Provider and sends to
+14 ;;Mental Health package
+15 NEW DGGAFSC,DGGAFDT,DGGAFPR,DGDFN
+16 SET DGGAFSC=$PIECE(DGHOLD,"^",6)
SET DGDFN=$PIECE(^DGPT(DGPTF,0),"^")
+17 SET DGGAFDT=$PIECE(^DGPT(DGPTF,0),"^",2)\1
+18 ;Provider
SET DGGAFPR=$PIECE($GET(^DGPT(DGPTF,"M",+DGMOV,"P")),"^",5)
+19 DO UPD^YSGAF(DGDFN,DGGAFSC,DGGAFDT,DGGAFPR,"I")
+20 ;;END GAF ENHANCEMENTS
+21 ;;
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 ; F DGI=5:1:9 I $P(DGREC,U,DGI) S DGPTIT($P(DGREC,U,DGI)_";ICD0(")=""
+4 NEW DGD
DO PTFICD^DGPTFUT(601,DGPTF,+P(DGZP,1),.DGD)
if $DATA(DGD)'=11
GOTO ENQ
+5 SET DGI=""
FOR
SET DGI=$ORDER(DGD(DGI))
if DGI=""
QUIT
SET DGPTIT($PIECE(DGD(DGI),U)_";ICD0(")=""
+6 SET DGHOLD=DGREC
+7 DO SCAN
+8 IF '$DATA(DGBPC(8))
IF $PIECE(DGHOLD,U,4)']""
GOTO CHK6Q
+9 SET DIE="^DGPT("
SET DA=DGPTF
SET DR="[DGPT 601 CLEANUP]"
+10 DO ^DIE
CHK6Q KILL DA,DR,DGHOLD,DGBPC,DGPTIT,DIE,DGREC,DGI,DGOUT
+1 QUIT
CHK401 ;--
+1 DO INIT
if DGOUT
GOTO ENQ
+2 ; G ENQ:'$D(^DGPT(DGPTF,"S",+DGSUR,0)) S DGREC=^(0)
+3 ; F DGI=8:1:12 I $P(DGREC,U,DGI) S DGPTIT($P(DGREC,U,DGI)_";ICD0(")=""
+4 NEW DGD
DO PTFICD^DGPTFUT(401,DGPTF,+DGSUR,.DGD)
if $DATA(DGD)'=11
GOTO ENQ
+5 SET DGI=""
FOR
SET DGI=$ORDER(DGD(DGI))
if DGI=""
QUIT
SET DGPTIT($PIECE(DGD(DGI),U)_";ICD0(")=""
+6 SET DGHOLD=$SELECT($DATA(^DGPT(DGPTF,"S",+DGSUR,300)):^(300),1:"")
+7 DO SCAN
+8 IF '$DATA(DGBPC)
IF DGHOLD']""
GOTO CHK4Q
+9 SET DIE="^DGPT("
SET DA=DGPTF
SET DR="[DGPT 401 CLEANUP]"
+10 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 ; G CHK7Q:'$D(^DGPT(DGPTF,70)) S DGREC=^(70)
+2 ; F DGI=10,16:1:24 I $P(DGREC,U,DGI) S DGPTIT($P(DGREC,U,DGI)_";ICD9(")=""
+3 NEW DGD
DO PTFICD^DGPTFUT(701,DGPTF,,.DGD)
if $DATA(DGD)'=11
GOTO ENQ
+4 SET DGI=""
FOR
SET DGI=$ORDER(DGD(DGI))
if DGI=""
QUIT
SET DGPTIT($PIECE(DGD(DGI),U)_";ICD9(")=""
+5 DO DC
DO SCAN
DO ANYPSY
DO FLAGCHK
+6 SET DGREC=$SELECT($DATA(^DGPT(DGPTF,300)):^(300),1:"")
SET DR=""
SET DA=DGPTF
SET DIE="^DGPT("
+7 DO GETNUM
+8 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 ; -- 850 Fix (BELOW), problem in fee basis when DGMOV is defined but no global ref.
+5 IF $DATA(DGMOV)
Begin DoDot:1
+6 SET DGSPEC=$PIECE($GET(^DGPT(DGPTF,"M",+$GET(DGMOV),0)),U,2)
+7 IF '$PIECE($GET(^DIC(42.4,+$GET(DGSPEC),0)),U,4)
KILL DGSPEC
End DoDot:1
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 ;
