DGPTDD ;ALB/LD - DD CALLS FOR PTF (#45) FILE;Nov 20, 2020@09:44
;;5.3;Registration;**58,932,1020,1076**;Aug 13, 1993;Build 4
;
; DD calls for the Suffix and Transferring Suffix fields of PTF
; file (#45).
;
ACTIVE(X,Y,DGADM) ; Suffix active during patient's admission date?
;
; DGEFDT -- Suffix Effective Date
; DGEFIEN -- Suffix Effective Date IEN
; DGSUFPTR -- Suffix pointer from Station Type file
;
; INPUT: X -- Suffix
; Y -- Station Type Number
; DGADM -- PTF IEN (use to get 2nd piece which is
; admission date or use DT if null)
; OUTPUT: DGACT -- Active during admission date? (1=YES,0=NO)
;
N DGACT,DGEFDT,DGEFIEN,DGFL,DGSUFPTR,DGI
S (DGACT,DGEFIEN,DGEFDT,DGFL,DGSUFPTR)=0
F DGI=0:0 S DGI=$O(^DIC(45.81,+$G(Y),"S","B",DGI)) Q:'DGI!$G(DGFL) D
.I $P($G(^DIC(45.68,DGI,0)),U)=$G(X) S DGSUFPTR=DGI,DGFL=1
I $D(^DGPT(+$G(DGADM),0)) S DGADM=+$P(^(0),U,2)
S DGADM=$S(+$G(DGADM)>0:-DGADM,1:-DT) S:$P(DGADM,".",2) DGADM=$P(DGADM,".") S DGADM=DGADM_.2359
S DGEFDT=+$O(^DIC(45.68,DGSUFPTR,"E","AEFF",DGADM))
I -(DGEFDT)'>0 S DGEFDT=+$O(^DIC(45.68,DGSUFPTR,"E","B",DGEFDT)),DGEFDT=-DGEFDT
S DGEFIEN=$O(^DIC(45.68,DGSUFPTR,"E","AEFF",DGEFDT,DGEFIEN))
S DGACT=$P($G(^DIC(45.68,+DGSUFPTR,"E",+DGEFIEN,0)),U,2)
Q +$G(DGACT)
;
ACTLST(DGADM) ; List of active suffixes
;
; DGEFFDT -- Suffix Effective Date
; DGEFFIEN -- Suffix Effective Date IEN
;
; INPUT: DGADM -- PTF IEN (use to get 2nd piece which is
; admission date or use DT if null)
; OUTPUT: List of active suffixes during admission date
;
N DGCTR,DGEFFDT,DGEFFIEN,DGI,DGOUT,DGST,DGX,DGY
S (DGEFFDT,DGOUT)=0,DGCTR=1
I $D(^DGPT(+$G(DGADM),0)) S DGADM=+$P(^(0),U,2)
S DGADM=$S(+$G(DGADM)>0:-DGADM,1:-DT) S:$P(DGADM,".",2) DGADM=$P(DGADM,".")
F DGST=0:0 S DGST=$O(^DIC(45.81,"B",DGST)) Q:'DGST D
.F DGI=0:0 S DGI=$O(^DIC(45.81,DGST,"S","B",DGI)) Q:'DGI D
..S DGEFFDT=+$O(^DIC(45.68,DGI,"E","AEFF",DGADM))
..I -(DGEFFDT)'>0 S DGEFFDT=$O(^DIC(45.68,DGI,"E","B",DGEFFDT)),DGEFFDT=-DGEFFDT
..S DGEFFIEN=0,DGEFFIEN=$O(^DIC(45.68,DGI,"E","AEFF",DGEFFDT,DGEFFIEN))
..S:$P($G(^DIC(45.68,DGI,"E",+DGEFFIEN,0)),U,2)=1 ^TMP("ACTSUFF",$J,DGCTR)=$P($G(^DIC(45.68,DGI,0)),U)_U_$P($G(^DIC(45.81,DGST,0)),U,2),DGCTR=DGCTR+1
W @IOF,"Choose From:",!
F DGX=0:0 S DGX=$O(^TMP("ACTSUFF",$J,DGX)) Q:'DGX!($G(DGOUT)) D
.I $Y>(IOSL-5) D NEXTSCR
.W:'$G(DGOUT) !,$P($G(^TMP("ACTSUFF",$J,DGX)),U),?15,$P($G(^TMP("ACTSUFF",$J,DGX)),U,2)
K ^TMP("ACTSUFF")
Q
NEXTSCR ;
F DGY=$Y:1:(IOSL-4) W !
S DIR(0)="E" D ^DIR K DIR I $D(DIRUT)!($D(DUOUT)) S DGOUT=1 K DIRUT,DTOUT,DUOUT G NEXTSCRQ
W @IOF,"Choose From:",!
NEXTSCRQ ;
Q
;=============================================
;QUEUE DATA CHANGE MESSAGES WHEN AN ICD
;DIAGNOSIS CODE IS RECORDED, EDITED OR DELETED
NOTIFY(OLDVAL,NEWVAL,DA,FILE,TYPE,ACTION) ;
;ALLOW THE SET CALL TO STORE THE DATA WHEN EDITING AN ENTRY
;DO NOT EXECUTE DURING A PRE-/POST-INSTALL OF THE RELATED INDEXES
I (($G(ACTION)="KILL")&($G(NEWVAL(1))'=""))!($G(XPDNM)'="") Q
N IEN,DFN,RECTYPE,SUB,NAME,NODE,EXISTS,FIELD,GTYPE,CLEAR,STATION,VAIN,VAERR
N INST
S IEN=$$IENS^DILF(.DA) Q:+IEN<1
S IEN("TOP")=$P(IEN,",",$L(IEN,",")-1),TYPE=$G(TYPE)
I TYPE="DISCHARGE" S DFN=$G(NEWVAL(1)),RECTYPE=$G(NEWVAL(2)),SUB=2
I (TYPE="MOVEMENT")!(TYPE="SERVICE") D
.S DFN=$P($G(^DGPT(IEN("TOP"),0)),U)
.S RECTYPE=$P($G(^DGPT(IEN("TOP"),0)),U,11),SUB=1
.I TYPE="MOVEMENT" Q
.I +$G(OLDVAL(3))=0,$G(NEWVAL(3))=1 S CLEAR="NEWVAL"
.I $G(OLDVAL(3))=1,+$G(NEWVAL(3))=0,'$$ALLCLEAR(.NEWVAL) S CLEAR="OLDVAL"
.I $G(CLEAR)'="" D
..F S SUB=$O(@CLEAR@(SUB)) Q:'+SUB S @CLEAR@(SUB)=""
..S SUB=0
..K CLEAR
.K OLDVAL(3),NEWVAL(3)
I TYPE="SERVICE46",$G(NEWVAL(2))>0 D
.S DFN=$P($G(^DGPT(NEWVAL(2),0)),U)
.S RECTYPE=$P($G(^DGPT(NEWVAL(2),0)),U,11),SUB=2,IEN("TOP")=NEWVAL(2)
.I $G(OLDVAL(11))="",$G(NEWVAL(11))>0 S CLEAR="NEWVAL"
.I $G(OLDVAL(11))>0,$G(NEWVAL(11))="",'$$ALLCLEAR(.NEWVAL) S CLEAR="OLDVAL"
.I $G(CLEAR)'="" D
..F S SUB=$O(@CLEAR@(SUB)) Q:'+SUB S @CLEAR@(SUB)=""
..S SUB=1
..K CLEAR
.K OLDVAL(11),NEWVAL(11)
;SKIP UNKNOWN TYPE AND CENSUS RECORDS (RECTYPE=2)
I (+$G(DFN)<1)!($G(RECTYPE)="")!($G(RECTYPE)=2)!('$D(SUB)) Q
S NAME="DG PTF ICD NOTIFIER",NODE=$$GETNODE(NAME,FILE,IEN("TOP"))
F S SUB=$O(OLDVAL(SUB)) Q:'+SUB D
.I OLDVAL(SUB)=NEWVAL(SUB) Q
.S FIELD=$$GETFIELD(TYPE,SUB) Q:FIELD=""
.S EXISTS=$D(^XTMP(NAME,NODE,TYPE,FIELD))
.S EXISTS("NEW")=$G(^XTMP(NAME,NODE,TYPE,FIELD,"NEW"))
.S EXISTS("OLD")=$G(^XTMP(NAME,NODE,TYPE,FIELD,"OLD"))
.;NEW RECORD/FIELD VALUE DELETED BEFORE NOTIFICATION SENT
.I EXISTS,EXISTS("NEW")=$G(OLDVAL(SUB)),$G(NEWVAL(SUB))="",EXISTS("OLD")="" D Q
..K ^XTMP(NAME,NODE,TYPE,FIELD)
.I 'EXISTS S ^XTMP(NAME,NODE,TYPE,FIELD,"OLD")=$G(OLDVAL(SUB))
.S ^XTMP(NAME,NODE,TYPE,FIELD,"NEW")=$G(NEWVAL(SUB))
S CLEAR=1,CLEAR("ALL")=1
F GTYPE="DISCHARGE","MOVEMENT","SERVICE","SERVICE46" D
.I $D(^XTMP(NAME,NODE,GTYPE)) D
..S SUB="" F S SUB=$O(^XTMP(NAME,NODE,GTYPE,SUB)) Q:SUB=""!('CLEAR) D
...I SUB'="IENS" S CLEAR=0,CLEAR("ALL")=0
..I CLEAR K ^XTMP(NAME,NODE,GTYPE)
..E S CLEAR=1
I CLEAR("ALL") D Q
.K ^XTMP(NAME,NODE),^XTMP(NAME,"B",FILE,IEN("TOP"))
.I $O(^XTMP(NAME,0))="" K ^XTMP(NAME)
S ^XTMP(NAME,NODE,TYPE,"IENS")=IEN
S ^XTMP(NAME,NODE,"DFN")=DFN
S ^XTMP(NAME,NODE,"INTEREST DATE")=$P($G(^DGPT(IEN("TOP"),0)),U,2)
S ^XTMP(NAME,NODE,"OCCURRED DATE")=$$NOW^XLFDT
S ^XTMP(NAME,NODE,"FILE")=FILE
D INP^VADPT
Q:+$G(VAERR)
I +$G(VAIN(2))>0 S ^XTMP(NAME,NODE,"PRIMARY PROVIDER")=+VAIN(2)
I +$G(VAIN(11))>0 S ^XTMP(NAME,NODE,"ATTENDING PHYSICIAN")=+VAIN(11)
I +$G(VAIN(4))>0 D
.S INST=+$P($G(^DIC(42,+VAIN(4),0)),U,11) Q:INST=0
.S INST=+$P($G(^DG(40.8,INST,0)),U,7) Q:INST=0
I +$G(VAIN(4))=0 D
.S INST=+$P($G(^DGPT(IEN("TOP"),0)),U,3) Q:INST=0
.D F4^XUAF4(INST,.STATION) Q:$P($G(STATION),U,1)=0
.S INST=$P(STATION,U,1)
I +$G(INST)>0 S ^XTMP(NAME,NODE,"INSTITUTION")=INST
S ^XTMP(NAME,"B",FILE,IEN("TOP"))=NODE
Q
ALLCLEAR(DATA) ;RETURN TRUE IF ALL NODES ARE EMPTY
N RETURN,SUB
S RETURN=1
S SUB="" F S SUB=$O(DATA(SUB)) Q:(SUB="")!('RETURN) D
.I $G(DATA(SUB))'="" S RETURN=0
Q RETURN
GETNODE(NAME,FILE,IEN) ;RETURN A FREE NODE IN NOTIFIER DATA
N RETURN
S RETURN=$G(^XTMP(NAME,"B",FILE,IEN))
I RETURN="" F S RETURN=$J_" "_$$NOW^XLFDT Q:'$D(^XTMP(NAME,RETURN)) H 1
S ^XTMP(NAME,0)=$$FMADD^XLFDT(DT,5)_U_DT_U_"PTF ICD NOTIFIER DATA"
Q RETURN
GETFIELD(TYPE,SUB) ;RETURN SUBSCRIPT FIELD NAME
N RETURN,NUMBER
S RETURN=""
I TYPE="DISCHARGE" D
.I SUB=3 S RETURN="PDX" Q
.I SUB>3,SUB<28 S NUMBER=SUB-3,RETURN="SDX"_$S(NUMBER<10:"0",1:"")_NUMBER Q
.I SUB=28 S RETURN="PDX-P1986"
I TYPE="MOVEMENT" D
.I SUB>1,SUB<27 S NUMBER=SUB-1,RETURN="DX"_$S(NUMBER<10:"0",1:"")_NUMBER
I TYPE="SERVICE",SUB=2 S RETURN="PDX"
I TYPE="SERVICE46" D
.I SUB=3 S RETURN="PDX" Q
.I SUB>3,SUB<11 S NUMBER=SUB-3,RETURN="SDX"_$S(NUMBER<10:"0",1:"")_NUMBER
Q RETURN
;
;=============================================
;QUEUE DATA CHANGE MESSAGES WHEN AN ICD
;PROCEDURE CODE IS RECORDED, EDITED OR DELETED
NOTIFYP(OLDVAL,NEWVAL,DA,FILE,TYPE,ACTION) ;
;ALLOW THE SET CALL TO STORE THE DATA WHEN EDITING AN ENTRY
;DO NOT EXECUTE DURING A PRE-/POST-INSTALL OF THE RELATED INDEXES
I (($G(ACTION)="KILL")&($G(NEWVAL(1))'=""))!($G(XPDNM)'="") Q
N IEN,DFN,RECTYPE,SUB,NAME,NODE,EXISTS,FIELD,GTYPE,CLEAR,STATION,INST
S IEN=$$IENS^DILF(.DA) Q:+IEN<1
S IEN("TOP")=$P(IEN,",",$L(IEN,",")-1),TYPE=$G(TYPE)
I TYPE="DISCHARGE" S DFN=$G(NEWVAL(1)),RECTYPE=$G(NEWVAL(2)),SUB=2
I (TYPE="PROCEDURE")!(TYPE="SURGERY") D
. S DFN=$P($G(^DGPT(IEN("TOP"),0)),U)
. S RECTYPE=$P($G(^DGPT(IEN("TOP"),0)),U,11),SUB=1
; SKIP UNKNOWN TYPE AND CENSUS RECORDS (RECTYPE=2)
I (+$G(DFN)<1)!($G(RECTYPE)="")!($G(RECTYPE)=2)!('$D(SUB)) Q
;
S NAME="DG PTF ICD OP NOTIFIER",NODE=$$GETNODE(NAME,FILE,IEN("TOP"))
F S SUB=$O(OLDVAL(SUB)) Q:'+SUB D
. I OLDVAL(SUB)=NEWVAL(SUB) Q
. S FIELD=$$GETFLD(TYPE,SUB) Q:FIELD=""
. S EXISTS=$D(^XTMP(NAME,NODE,TYPE,FIELD))
. S EXISTS("NEW")=$G(^XTMP(NAME,NODE,TYPE,FIELD,"NEW"))
. S EXISTS("OLD")=$G(^XTMP(NAME,NODE,TYPE,FIELD,"OLD"))
. ;NEW RECORD/FIELD VALUE DELETED BEFORE NOTIFICATION SENT
. I EXISTS,EXISTS("NEW")=$G(OLDVAL(SUB)),$G(NEWVAL(SUB))="",EXISTS("OLD")="" D Q
.. K ^XTMP(NAME,NODE,TYPE,FIELD)
. I 'EXISTS S ^XTMP(NAME,NODE,TYPE,FIELD,"OLD")=$G(OLDVAL(SUB))
. S ^XTMP(NAME,NODE,TYPE,FIELD,"NEW")=$G(NEWVAL(SUB))
;
S CLEAR=1,CLEAR("ALL")=1
F GTYPE="DISCHARGE","PROCEDURE","SURGERY" D
. I $D(^XTMP(NAME,NODE,GTYPE)) D
.. S SUB="" F S SUB=$O(^XTMP(NAME,NODE,GTYPE,SUB)) Q:SUB=""!('CLEAR) D
... I SUB'="IENS" S CLEAR=0,CLEAR("ALL")=0
.. I CLEAR K ^XTMP(NAME,NODE,GTYPE)
.. E S CLEAR=1
I CLEAR("ALL") D Q
. K ^XTMP(NAME,NODE),^XTMP(NAME,"B",FILE,IEN("TOP"))
. I $O(^XTMP(NAME,0))="" K ^XTMP(NAME)
;
S ^XTMP(NAME,NODE,TYPE,"IENS")=IEN
S ^XTMP(NAME,NODE,"DFN")=DFN
S ^XTMP(NAME,NODE,"INTEREST DATE")=$P($G(^DGPT(IEN("TOP"),0)),U,2)
S ^XTMP(NAME,NODE,"OCCURRED DATE")=$$NOW^XLFDT
S ^XTMP(NAME,NODE,"FILE")=FILE
S INST=+$P($G(^DGPT(IEN("TOP"),0)),U,3) I INST'=0 D
. D F4^XUAF4(INST,.STATION) Q:$P($G(STATION),U,1)=0
. S INST=$P(STATION,U,1)
I +$G(INST)>0 S ^XTMP(NAME,NODE,"INSTITUTION")=INST
S ^XTMP(NAME,"B",FILE,IEN("TOP"))=NODE
Q
;
GETFLD(TYPE,SUB) ;RETURN SUBSCRIPT FIELD NAME
N RETURN,NUMBER
S RETURN=""
I TYPE="DISCHARGE" D
. S NUMBER=SUB-2,RETURN="OPC"_$S(NUMBER<10:"0",1:"")_NUMBER Q
I TYPE="PROCEDURE" D
. S NUMBER=SUB-1,RETURN="OPC"_$S(NUMBER<10:"0",1:"")_NUMBER
I TYPE="SURGERY" D
. S NUMBER=SUB-1,RETURN="OPC"_$S(NUMBER<10:"0",1:"")_NUMBER
Q RETURN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTDD 9876 printed Mar 13, 2025@21:56:39 Page 2
DGPTDD ;ALB/LD - DD CALLS FOR PTF (#45) FILE;Nov 20, 2020@09:44
+1 ;;5.3;Registration;**58,932,1020,1076**;Aug 13, 1993;Build 4
+2 ;
+3 ; DD calls for the Suffix and Transferring Suffix fields of PTF
+4 ; file (#45).
+5 ;
ACTIVE(X,Y,DGADM) ; Suffix active during patient's admission date?
+1 ;
+2 ; DGEFDT -- Suffix Effective Date
+3 ; DGEFIEN -- Suffix Effective Date IEN
+4 ; DGSUFPTR -- Suffix pointer from Station Type file
+5 ;
+6 ; INPUT: X -- Suffix
+7 ; Y -- Station Type Number
+8 ; DGADM -- PTF IEN (use to get 2nd piece which is
+9 ; admission date or use DT if null)
+10 ; OUTPUT: DGACT -- Active during admission date? (1=YES,0=NO)
+11 ;
+12 NEW DGACT,DGEFDT,DGEFIEN,DGFL,DGSUFPTR,DGI
+13 SET (DGACT,DGEFIEN,DGEFDT,DGFL,DGSUFPTR)=0
+14 FOR DGI=0:0
SET DGI=$ORDER(^DIC(45.81,+$GET(Y),"S","B",DGI))
if 'DGI!$GET(DGFL)
QUIT
Begin DoDot:1
+15 IF $PIECE($GET(^DIC(45.68,DGI,0)),U)=$GET(X)
SET DGSUFPTR=DGI
SET DGFL=1
End DoDot:1
+16 IF $DATA(^DGPT(+$GET(DGADM),0))
SET DGADM=+$PIECE(^(0),U,2)
+17 SET DGADM=$SELECT(+$GET(DGADM)>0:-DGADM,1:-DT)
if $PIECE(DGADM,".",2)
SET DGADM=$PIECE(DGADM,".")
SET DGADM=DGADM_.2359
+18 SET DGEFDT=+$ORDER(^DIC(45.68,DGSUFPTR,"E","AEFF",DGADM))
+19 IF -(DGEFDT)'>0
SET DGEFDT=+$ORDER(^DIC(45.68,DGSUFPTR,"E","B",DGEFDT))
SET DGEFDT=-DGEFDT
+20 SET DGEFIEN=$ORDER(^DIC(45.68,DGSUFPTR,"E","AEFF",DGEFDT,DGEFIEN))
+21 SET DGACT=$PIECE($GET(^DIC(45.68,+DGSUFPTR,"E",+DGEFIEN,0)),U,2)
+22 QUIT +$GET(DGACT)
+23 ;
ACTLST(DGADM) ; List of active suffixes
+1 ;
+2 ; DGEFFDT -- Suffix Effective Date
+3 ; DGEFFIEN -- Suffix Effective Date IEN
+4 ;
+5 ; INPUT: DGADM -- PTF IEN (use to get 2nd piece which is
+6 ; admission date or use DT if null)
+7 ; OUTPUT: List of active suffixes during admission date
+8 ;
+9 NEW DGCTR,DGEFFDT,DGEFFIEN,DGI,DGOUT,DGST,DGX,DGY
+10 SET (DGEFFDT,DGOUT)=0
SET DGCTR=1
+11 IF $DATA(^DGPT(+$GET(DGADM),0))
SET DGADM=+$PIECE(^(0),U,2)
+12 SET DGADM=$SELECT(+$GET(DGADM)>0:-DGADM,1:-DT)
if $PIECE(DGADM,".",2)
SET DGADM=$PIECE(DGADM,".")
+13 FOR DGST=0:0
SET DGST=$ORDER(^DIC(45.81,"B",DGST))
if 'DGST
QUIT
Begin DoDot:1
+14 FOR DGI=0:0
SET DGI=$ORDER(^DIC(45.81,DGST,"S","B",DGI))
if 'DGI
QUIT
Begin DoDot:2
+15 SET DGEFFDT=+$ORDER(^DIC(45.68,DGI,"E","AEFF",DGADM))
+16 IF -(DGEFFDT)'>0
SET DGEFFDT=$ORDER(^DIC(45.68,DGI,"E","B",DGEFFDT))
SET DGEFFDT=-DGEFFDT
+17 SET DGEFFIEN=0
SET DGEFFIEN=$ORDER(^DIC(45.68,DGI,"E","AEFF",DGEFFDT,DGEFFIEN))
+18 if $PIECE($GET(^DIC(45.68,DGI,"E",+DGEFFIEN,0)),U,2)=1
SET ^TMP("ACTSUFF",$JOB,DGCTR)=$PIECE($GET(^DIC(45.68,DGI,0)),U)_U_$PIECE($GET(^DIC(45.81,DGST,0)),U,2)
SET DGCTR=DGCTR+1
End DoDot:2
End DoDot:1
+19 WRITE @IOF,"Choose From:",!
+20 FOR DGX=0:0
SET DGX=$ORDER(^TMP("ACTSUFF",$JOB,DGX))
if 'DGX!($GET(DGOUT))
QUIT
Begin DoDot:1
+21 IF $Y>(IOSL-5)
DO NEXTSCR
+22 if '$GET(DGOUT)
WRITE !,$PIECE($GET(^TMP("ACTSUFF",$JOB,DGX)),U),?15,$PIECE($GET(^TMP("ACTSUFF",$JOB,DGX)),U,2)
End DoDot:1
+23 KILL ^TMP("ACTSUFF")
+24 QUIT
NEXTSCR ;
+1 FOR DGY=$Y:1:(IOSL-4)
WRITE !
+2 SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!($DATA(DUOUT))
SET DGOUT=1
KILL DIRUT,DTOUT,DUOUT
GOTO NEXTSCRQ
+3 WRITE @IOF,"Choose From:",!
NEXTSCRQ ;
+1 QUIT
+2 ;=============================================
+3 ;QUEUE DATA CHANGE MESSAGES WHEN AN ICD
+4 ;DIAGNOSIS CODE IS RECORDED, EDITED OR DELETED
NOTIFY(OLDVAL,NEWVAL,DA,FILE,TYPE,ACTION) ;
+1 ;ALLOW THE SET CALL TO STORE THE DATA WHEN EDITING AN ENTRY
+2 ;DO NOT EXECUTE DURING A PRE-/POST-INSTALL OF THE RELATED INDEXES
+3 IF (($GET(ACTION)="KILL")&($GET(NEWVAL(1))'=""))!($GET(XPDNM)'="")
QUIT
+4 NEW IEN,DFN,RECTYPE,SUB,NAME,NODE,EXISTS,FIELD,GTYPE,CLEAR,STATION,VAIN,VAERR
+5 NEW INST
+6 SET IEN=$$IENS^DILF(.DA)
if +IEN<1
QUIT
+7 SET IEN("TOP")=$PIECE(IEN,",",$LENGTH(IEN,",")-1)
SET TYPE=$GET(TYPE)
+8 IF TYPE="DISCHARGE"
SET DFN=$GET(NEWVAL(1))
SET RECTYPE=$GET(NEWVAL(2))
SET SUB=2
+9 IF (TYPE="MOVEMENT")!(TYPE="SERVICE")
Begin DoDot:1
+10 SET DFN=$PIECE($GET(^DGPT(IEN("TOP"),0)),U)
+11 SET RECTYPE=$PIECE($GET(^DGPT(IEN("TOP"),0)),U,11)
SET SUB=1
+12 IF TYPE="MOVEMENT"
QUIT
+13 IF +$GET(OLDVAL(3))=0
IF $GET(NEWVAL(3))=1
SET CLEAR="NEWVAL"
+14 IF $GET(OLDVAL(3))=1
IF +$GET(NEWVAL(3))=0
IF '$$ALLCLEAR(.NEWVAL)
SET CLEAR="OLDVAL"
+15 IF $GET(CLEAR)'=""
Begin DoDot:2
+16 FOR
SET SUB=$ORDER(@CLEAR@(SUB))
if '+SUB
QUIT
SET @CLEAR@(SUB)=""
+17 SET SUB=0
+18 KILL CLEAR
End DoDot:2
+19 KILL OLDVAL(3),NEWVAL(3)
End DoDot:1
+20 IF TYPE="SERVICE46"
IF $GET(NEWVAL(2))>0
Begin DoDot:1
+21 SET DFN=$PIECE($GET(^DGPT(NEWVAL(2),0)),U)
+22 SET RECTYPE=$PIECE($GET(^DGPT(NEWVAL(2),0)),U,11)
SET SUB=2
SET IEN("TOP")=NEWVAL(2)
+23 IF $GET(OLDVAL(11))=""
IF $GET(NEWVAL(11))>0
SET CLEAR="NEWVAL"
+24 IF $GET(OLDVAL(11))>0
IF $GET(NEWVAL(11))=""
IF '$$ALLCLEAR(.NEWVAL)
SET CLEAR="OLDVAL"
+25 IF $GET(CLEAR)'=""
Begin DoDot:2
+26 FOR
SET SUB=$ORDER(@CLEAR@(SUB))
if '+SUB
QUIT
SET @CLEAR@(SUB)=""
+27 SET SUB=1
+28 KILL CLEAR
End DoDot:2
+29 KILL OLDVAL(11),NEWVAL(11)
End DoDot:1
+30 ;SKIP UNKNOWN TYPE AND CENSUS RECORDS (RECTYPE=2)
+31 IF (+$GET(DFN)<1)!($GET(RECTYPE)="")!($GET(RECTYPE)=2)!('$DATA(SUB))
QUIT
+32 SET NAME="DG PTF ICD NOTIFIER"
SET NODE=$$GETNODE(NAME,FILE,IEN("TOP"))
+33 FOR
SET SUB=$ORDER(OLDVAL(SUB))
if '+SUB
QUIT
Begin DoDot:1
+34 IF OLDVAL(SUB)=NEWVAL(SUB)
QUIT
+35 SET FIELD=$$GETFIELD(TYPE,SUB)
if FIELD=""
QUIT
+36 SET EXISTS=$DATA(^XTMP(NAME,NODE,TYPE,FIELD))
+37 SET EXISTS("NEW")=$GET(^XTMP(NAME,NODE,TYPE,FIELD,"NEW"))
+38 SET EXISTS("OLD")=$GET(^XTMP(NAME,NODE,TYPE,FIELD,"OLD"))
+39 ;NEW RECORD/FIELD VALUE DELETED BEFORE NOTIFICATION SENT
+40 IF EXISTS
IF EXISTS("NEW")=$GET(OLDVAL(SUB))
IF $GET(NEWVAL(SUB))=""
IF EXISTS("OLD")=""
Begin DoDot:2
+41 KILL ^XTMP(NAME,NODE,TYPE,FIELD)
End DoDot:2
QUIT
+42 IF 'EXISTS
SET ^XTMP(NAME,NODE,TYPE,FIELD,"OLD")=$GET(OLDVAL(SUB))
+43 SET ^XTMP(NAME,NODE,TYPE,FIELD,"NEW")=$GET(NEWVAL(SUB))
End DoDot:1
+44 SET CLEAR=1
SET CLEAR("ALL")=1
+45 FOR GTYPE="DISCHARGE","MOVEMENT","SERVICE","SERVICE46"
Begin DoDot:1
+46 IF $DATA(^XTMP(NAME,NODE,GTYPE))
Begin DoDot:2
+47 SET SUB=""
FOR
SET SUB=$ORDER(^XTMP(NAME,NODE,GTYPE,SUB))
if SUB=""!('CLEAR)
QUIT
Begin DoDot:3
+48 IF SUB'="IENS"
SET CLEAR=0
SET CLEAR("ALL")=0
End DoDot:3
+49 IF CLEAR
KILL ^XTMP(NAME,NODE,GTYPE)
+50 IF '$TEST
SET CLEAR=1
End DoDot:2
End DoDot:1
+51 IF CLEAR("ALL")
Begin DoDot:1
+52 KILL ^XTMP(NAME,NODE),^XTMP(NAME,"B",FILE,IEN("TOP"))
+53 IF $ORDER(^XTMP(NAME,0))=""
KILL ^XTMP(NAME)
End DoDot:1
QUIT
+54 SET ^XTMP(NAME,NODE,TYPE,"IENS")=IEN
+55 SET ^XTMP(NAME,NODE,"DFN")=DFN
+56 SET ^XTMP(NAME,NODE,"INTEREST DATE")=$PIECE($GET(^DGPT(IEN("TOP"),0)),U,2)
+57 SET ^XTMP(NAME,NODE,"OCCURRED DATE")=$$NOW^XLFDT
+58 SET ^XTMP(NAME,NODE,"FILE")=FILE
+59 DO INP^VADPT
+60 if +$GET(VAERR)
QUIT
+61 IF +$GET(VAIN(2))>0
SET ^XTMP(NAME,NODE,"PRIMARY PROVIDER")=+VAIN(2)
+62 IF +$GET(VAIN(11))>0
SET ^XTMP(NAME,NODE,"ATTENDING PHYSICIAN")=+VAIN(11)
+63 IF +$GET(VAIN(4))>0
Begin DoDot:1
+64 SET INST=+$PIECE($GET(^DIC(42,+VAIN(4),0)),U,11)
if INST=0
QUIT
+65 SET INST=+$PIECE($GET(^DG(40.8,INST,0)),U,7)
if INST=0
QUIT
End DoDot:1
+66 IF +$GET(VAIN(4))=0
Begin DoDot:1
+67 SET INST=+$PIECE($GET(^DGPT(IEN("TOP"),0)),U,3)
if INST=0
QUIT
+68 DO F4^XUAF4(INST,.STATION)
if $PIECE($GET(STATION),U,1)=0
QUIT
+69 SET INST=$PIECE(STATION,U,1)
End DoDot:1
+70 IF +$GET(INST)>0
SET ^XTMP(NAME,NODE,"INSTITUTION")=INST
+71 SET ^XTMP(NAME,"B",FILE,IEN("TOP"))=NODE
+72 QUIT
ALLCLEAR(DATA) ;RETURN TRUE IF ALL NODES ARE EMPTY
+1 NEW RETURN,SUB
+2 SET RETURN=1
+3 SET SUB=""
FOR
SET SUB=$ORDER(DATA(SUB))
if (SUB="")!('RETURN)
QUIT
Begin DoDot:1
+4 IF $GET(DATA(SUB))'=""
SET RETURN=0
End DoDot:1
+5 QUIT RETURN
GETNODE(NAME,FILE,IEN) ;RETURN A FREE NODE IN NOTIFIER DATA
+1 NEW RETURN
+2 SET RETURN=$GET(^XTMP(NAME,"B",FILE,IEN))
+3 IF RETURN=""
FOR
SET RETURN=$JOB_" "_$$NOW^XLFDT
if '$DATA(^XTMP(NAME,RETURN))
QUIT
HANG 1
+4 SET ^XTMP(NAME,0)=$$FMADD^XLFDT(DT,5)_U_DT_U_"PTF ICD NOTIFIER DATA"
+5 QUIT RETURN
GETFIELD(TYPE,SUB) ;RETURN SUBSCRIPT FIELD NAME
+1 NEW RETURN,NUMBER
+2 SET RETURN=""
+3 IF TYPE="DISCHARGE"
Begin DoDot:1
+4 IF SUB=3
SET RETURN="PDX"
QUIT
+5 IF SUB>3
IF SUB<28
SET NUMBER=SUB-3
SET RETURN="SDX"_$SELECT(NUMBER<10:"0",1:"")_NUMBER
QUIT
+6 IF SUB=28
SET RETURN="PDX-P1986"
End DoDot:1
+7 IF TYPE="MOVEMENT"
Begin DoDot:1
+8 IF SUB>1
IF SUB<27
SET NUMBER=SUB-1
SET RETURN="DX"_$SELECT(NUMBER<10:"0",1:"")_NUMBER
End DoDot:1
+9 IF TYPE="SERVICE"
IF SUB=2
SET RETURN="PDX"
+10 IF TYPE="SERVICE46"
Begin DoDot:1
+11 IF SUB=3
SET RETURN="PDX"
QUIT
+12 IF SUB>3
IF SUB<11
SET NUMBER=SUB-3
SET RETURN="SDX"_$SELECT(NUMBER<10:"0",1:"")_NUMBER
End DoDot:1
+13 QUIT RETURN
+14 ;
+15 ;=============================================
+16 ;QUEUE DATA CHANGE MESSAGES WHEN AN ICD
+17 ;PROCEDURE CODE IS RECORDED, EDITED OR DELETED
NOTIFYP(OLDVAL,NEWVAL,DA,FILE,TYPE,ACTION) ;
+1 ;ALLOW THE SET CALL TO STORE THE DATA WHEN EDITING AN ENTRY
+2 ;DO NOT EXECUTE DURING A PRE-/POST-INSTALL OF THE RELATED INDEXES
+3 IF (($GET(ACTION)="KILL")&($GET(NEWVAL(1))'=""))!($GET(XPDNM)'="")
QUIT
+4 NEW IEN,DFN,RECTYPE,SUB,NAME,NODE,EXISTS,FIELD,GTYPE,CLEAR,STATION,INST
+5 SET IEN=$$IENS^DILF(.DA)
if +IEN<1
QUIT
+6 SET IEN("TOP")=$PIECE(IEN,",",$LENGTH(IEN,",")-1)
SET TYPE=$GET(TYPE)
+7 IF TYPE="DISCHARGE"
SET DFN=$GET(NEWVAL(1))
SET RECTYPE=$GET(NEWVAL(2))
SET SUB=2
+8 IF (TYPE="PROCEDURE")!(TYPE="SURGERY")
Begin DoDot:1
+9 SET DFN=$PIECE($GET(^DGPT(IEN("TOP"),0)),U)
+10 SET RECTYPE=$PIECE($GET(^DGPT(IEN("TOP"),0)),U,11)
SET SUB=1
End DoDot:1
+11 ; SKIP UNKNOWN TYPE AND CENSUS RECORDS (RECTYPE=2)
+12 IF (+$GET(DFN)<1)!($GET(RECTYPE)="")!($GET(RECTYPE)=2)!('$DATA(SUB))
QUIT
+13 ;
+14 SET NAME="DG PTF ICD OP NOTIFIER"
SET NODE=$$GETNODE(NAME,FILE,IEN("TOP"))
+15 FOR
SET SUB=$ORDER(OLDVAL(SUB))
if '+SUB
QUIT
Begin DoDot:1
+16 IF OLDVAL(SUB)=NEWVAL(SUB)
QUIT
+17 SET FIELD=$$GETFLD(TYPE,SUB)
if FIELD=""
QUIT
+18 SET EXISTS=$DATA(^XTMP(NAME,NODE,TYPE,FIELD))
+19 SET EXISTS("NEW")=$GET(^XTMP(NAME,NODE,TYPE,FIELD,"NEW"))
+20 SET EXISTS("OLD")=$GET(^XTMP(NAME,NODE,TYPE,FIELD,"OLD"))
+21 ;NEW RECORD/FIELD VALUE DELETED BEFORE NOTIFICATION SENT
+22 IF EXISTS
IF EXISTS("NEW")=$GET(OLDVAL(SUB))
IF $GET(NEWVAL(SUB))=""
IF EXISTS("OLD")=""
Begin DoDot:2
+23 KILL ^XTMP(NAME,NODE,TYPE,FIELD)
End DoDot:2
QUIT
+24 IF 'EXISTS
SET ^XTMP(NAME,NODE,TYPE,FIELD,"OLD")=$GET(OLDVAL(SUB))
+25 SET ^XTMP(NAME,NODE,TYPE,FIELD,"NEW")=$GET(NEWVAL(SUB))
End DoDot:1
+26 ;
+27 SET CLEAR=1
SET CLEAR("ALL")=1
+28 FOR GTYPE="DISCHARGE","PROCEDURE","SURGERY"
Begin DoDot:1
+29 IF $DATA(^XTMP(NAME,NODE,GTYPE))
Begin DoDot:2
+30 SET SUB=""
FOR
SET SUB=$ORDER(^XTMP(NAME,NODE,GTYPE,SUB))
if SUB=""!('CLEAR)
QUIT
Begin DoDot:3
+31 IF SUB'="IENS"
SET CLEAR=0
SET CLEAR("ALL")=0
End DoDot:3
+32 IF CLEAR
KILL ^XTMP(NAME,NODE,GTYPE)
+33 IF '$TEST
SET CLEAR=1
End DoDot:2
End DoDot:1
+34 IF CLEAR("ALL")
Begin DoDot:1
+35 KILL ^XTMP(NAME,NODE),^XTMP(NAME,"B",FILE,IEN("TOP"))
+36 IF $ORDER(^XTMP(NAME,0))=""
KILL ^XTMP(NAME)
End DoDot:1
QUIT
+37 ;
+38 SET ^XTMP(NAME,NODE,TYPE,"IENS")=IEN
+39 SET ^XTMP(NAME,NODE,"DFN")=DFN
+40 SET ^XTMP(NAME,NODE,"INTEREST DATE")=$PIECE($GET(^DGPT(IEN("TOP"),0)),U,2)
+41 SET ^XTMP(NAME,NODE,"OCCURRED DATE")=$$NOW^XLFDT
+42 SET ^XTMP(NAME,NODE,"FILE")=FILE
+43 SET INST=+$PIECE($GET(^DGPT(IEN("TOP"),0)),U,3)
IF INST'=0
Begin DoDot:1
+44 DO F4^XUAF4(INST,.STATION)
if $PIECE($GET(STATION),U,1)=0
QUIT
+45 SET INST=$PIECE(STATION,U,1)
End DoDot:1
+46 IF +$GET(INST)>0
SET ^XTMP(NAME,NODE,"INSTITUTION")=INST
+47 SET ^XTMP(NAME,"B",FILE,IEN("TOP"))=NODE
+48 QUIT
+49 ;
GETFLD(TYPE,SUB) ;RETURN SUBSCRIPT FIELD NAME
+1 NEW RETURN,NUMBER
+2 SET RETURN=""
+3 IF TYPE="DISCHARGE"
Begin DoDot:1
+4 SET NUMBER=SUB-2
SET RETURN="OPC"_$SELECT(NUMBER<10:"0",1:"")_NUMBER
QUIT
End DoDot:1
+5 IF TYPE="PROCEDURE"
Begin DoDot:1
+6 SET NUMBER=SUB-1
SET RETURN="OPC"_$SELECT(NUMBER<10:"0",1:"")_NUMBER
End DoDot:1
+7 IF TYPE="SURGERY"
Begin DoDot:1
+8 SET NUMBER=SUB-1
SET RETURN="OPC"_$SELECT(NUMBER<10:"0",1:"")_NUMBER
End DoDot:1
+9 QUIT RETURN
