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

DGPTDD.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ; DD calls for the Suffix and Transferring Suffix fields of PTF
  1.  ; file (#45).
  1.  ;
  1. ACTIVE(X,Y,DGADM) ; Suffix active during patient's admission date?
  1.  ;
  1.  ;         DGEFDT  -- Suffix Effective Date
  1.  ;         DGEFIEN -- Suffix Effective Date IEN
  1.  ;        DGSUFPTR -- Suffix pointer from Station Type file
  1.  ;
  1.  ;  INPUT:     X   --  Suffix
  1.  ;             Y   --  Station Type Number
  1.  ;         DGADM   --  PTF IEN (use to get 2nd piece which is
  1.  ;                              admission date or use DT if null)
  1.  ; OUTPUT: DGACT   --  Active during admission date? (1=YES,0=NO)
  1.  ;
  1.  N DGACT,DGEFDT,DGEFIEN,DGFL,DGSUFPTR,DGI
  1.  S (DGACT,DGEFIEN,DGEFDT,DGFL,DGSUFPTR)=0
  1.  F DGI=0:0 S DGI=$O(^DIC(45.81,+$G(Y),"S","B",DGI)) Q:'DGI!$G(DGFL)  D
  1.  .I $P($G(^DIC(45.68,DGI,0)),U)=$G(X) S DGSUFPTR=DGI,DGFL=1
  1.  I $D(^DGPT(+$G(DGADM),0)) S DGADM=+$P(^(0),U,2)
  1.  S DGADM=$S(+$G(DGADM)>0:-DGADM,1:-DT) S:$P(DGADM,".",2) DGADM=$P(DGADM,".") S DGADM=DGADM_.2359
  1.  S DGEFDT=+$O(^DIC(45.68,DGSUFPTR,"E","AEFF",DGADM))
  1.  I -(DGEFDT)'>0 S DGEFDT=+$O(^DIC(45.68,DGSUFPTR,"E","B",DGEFDT)),DGEFDT=-DGEFDT
  1.  S DGEFIEN=$O(^DIC(45.68,DGSUFPTR,"E","AEFF",DGEFDT,DGEFIEN))
  1.  S DGACT=$P($G(^DIC(45.68,+DGSUFPTR,"E",+DGEFIEN,0)),U,2)
  1.  Q +$G(DGACT)
  1.  ;
  1. ACTLST(DGADM) ;    List of active suffixes
  1.  ;
  1.  ;          DGEFFDT -- Suffix Effective Date
  1.  ;         DGEFFIEN -- Suffix Effective Date IEN
  1.  ;
  1.  ;  INPUT:     DGADM  --  PTF IEN (use to get 2nd piece which is
  1.  ;                                 admission date or use DT if null)
  1.  ; OUTPUT:     List of active suffixes during admission date
  1.  ;
  1.  N DGCTR,DGEFFDT,DGEFFIEN,DGI,DGOUT,DGST,DGX,DGY
  1.  S (DGEFFDT,DGOUT)=0,DGCTR=1
  1.  I $D(^DGPT(+$G(DGADM),0)) S DGADM=+$P(^(0),U,2)
  1.  S DGADM=$S(+$G(DGADM)>0:-DGADM,1:-DT) S:$P(DGADM,".",2) DGADM=$P(DGADM,".")
  1.  F DGST=0:0 S DGST=$O(^DIC(45.81,"B",DGST)) Q:'DGST  D
  1.  .F DGI=0:0 S DGI=$O(^DIC(45.81,DGST,"S","B",DGI)) Q:'DGI  D
  1.  ..S DGEFFDT=+$O(^DIC(45.68,DGI,"E","AEFF",DGADM))
  1.  ..I -(DGEFFDT)'>0 S DGEFFDT=$O(^DIC(45.68,DGI,"E","B",DGEFFDT)),DGEFFDT=-DGEFFDT
  1.  ..S DGEFFIEN=0,DGEFFIEN=$O(^DIC(45.68,DGI,"E","AEFF",DGEFFDT,DGEFFIEN))
  1.  ..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
  1.  W @IOF,"Choose From:",!
  1.  F DGX=0:0 S DGX=$O(^TMP("ACTSUFF",$J,DGX)) Q:'DGX!($G(DGOUT))  D
  1.  .I $Y>(IOSL-5) D NEXTSCR
  1.  .W:'$G(DGOUT) !,$P($G(^TMP("ACTSUFF",$J,DGX)),U),?15,$P($G(^TMP("ACTSUFF",$J,DGX)),U,2)
  1.  K ^TMP("ACTSUFF")
  1.  Q
  1. NEXTSCR ;
  1.  F DGY=$Y:1:(IOSL-4) W !
  1.  S DIR(0)="E" D ^DIR K DIR I $D(DIRUT)!($D(DUOUT)) S DGOUT=1 K DIRUT,DTOUT,DUOUT G NEXTSCRQ
  1.  W @IOF,"Choose From:",!
  1. NEXTSCRQ ;
  1.  Q
  1.  ;=============================================
  1.  ;QUEUE DATA CHANGE MESSAGES WHEN AN ICD
  1.  ;DIAGNOSIS CODE IS RECORDED, EDITED OR DELETED
  1. NOTIFY(OLDVAL,NEWVAL,DA,FILE,TYPE,ACTION) ;
  1.  ;ALLOW THE SET CALL TO STORE THE DATA WHEN EDITING AN ENTRY
  1.  ;DO NOT EXECUTE DURING A PRE-/POST-INSTALL OF THE RELATED INDEXES
  1.  I (($G(ACTION)="KILL")&($G(NEWVAL(1))'=""))!($G(XPDNM)'="") Q
  1.  N IEN,DFN,RECTYPE,SUB,NAME,NODE,EXISTS,FIELD,GTYPE,CLEAR,STATION,VAIN,VAERR
  1.  N INST
  1.  S IEN=$$IENS^DILF(.DA) Q:+IEN<1
  1.  S IEN("TOP")=$P(IEN,",",$L(IEN,",")-1),TYPE=$G(TYPE)
  1.  I TYPE="DISCHARGE" S DFN=$G(NEWVAL(1)),RECTYPE=$G(NEWVAL(2)),SUB=2
  1.  I (TYPE="MOVEMENT")!(TYPE="SERVICE") D
  1.  .S DFN=$P($G(^DGPT(IEN("TOP"),0)),U)
  1.  .S RECTYPE=$P($G(^DGPT(IEN("TOP"),0)),U,11),SUB=1
  1.  .I TYPE="MOVEMENT" Q
  1.  .I +$G(OLDVAL(3))=0,$G(NEWVAL(3))=1 S CLEAR="NEWVAL"
  1.  .I $G(OLDVAL(3))=1,+$G(NEWVAL(3))=0,'$$ALLCLEAR(.NEWVAL) S CLEAR="OLDVAL"
  1.  .I $G(CLEAR)'="" D
  1.  ..F  S SUB=$O(@CLEAR@(SUB)) Q:'+SUB  S @CLEAR@(SUB)=""
  1.  ..S SUB=0
  1.  ..K CLEAR
  1.  .K OLDVAL(3),NEWVAL(3)
  1.  I TYPE="SERVICE46",$G(NEWVAL(2))>0 D
  1.  .S DFN=$P($G(^DGPT(NEWVAL(2),0)),U)
  1.  .S RECTYPE=$P($G(^DGPT(NEWVAL(2),0)),U,11),SUB=2,IEN("TOP")=NEWVAL(2)
  1.  .I $G(OLDVAL(11))="",$G(NEWVAL(11))>0 S CLEAR="NEWVAL"
  1.  .I $G(OLDVAL(11))>0,$G(NEWVAL(11))="",'$$ALLCLEAR(.NEWVAL) S CLEAR="OLDVAL"
  1.  .I $G(CLEAR)'="" D
  1.  ..F  S SUB=$O(@CLEAR@(SUB)) Q:'+SUB  S @CLEAR@(SUB)=""
  1.  ..S SUB=1
  1.  ..K CLEAR
  1.  .K OLDVAL(11),NEWVAL(11)
  1.  ;SKIP UNKNOWN TYPE AND CENSUS RECORDS (RECTYPE=2)
  1.  I (+$G(DFN)<1)!($G(RECTYPE)="")!($G(RECTYPE)=2)!('$D(SUB)) Q
  1.  S NAME="DG PTF ICD NOTIFIER",NODE=$$GETNODE(NAME,FILE,IEN("TOP"))
  1.  F  S SUB=$O(OLDVAL(SUB)) Q:'+SUB  D
  1.  .I OLDVAL(SUB)=NEWVAL(SUB) Q
  1.  .S FIELD=$$GETFIELD(TYPE,SUB) Q:FIELD=""
  1.  .S EXISTS=$D(^XTMP(NAME,NODE,TYPE,FIELD))
  1.  .S EXISTS("NEW")=$G(^XTMP(NAME,NODE,TYPE,FIELD,"NEW"))
  1.  .S EXISTS("OLD")=$G(^XTMP(NAME,NODE,TYPE,FIELD,"OLD"))
  1.  .;NEW RECORD/FIELD VALUE DELETED BEFORE NOTIFICATION SENT
  1.  .I EXISTS,EXISTS("NEW")=$G(OLDVAL(SUB)),$G(NEWVAL(SUB))="",EXISTS("OLD")="" D  Q
  1.  ..K ^XTMP(NAME,NODE,TYPE,FIELD)
  1.  .I 'EXISTS S ^XTMP(NAME,NODE,TYPE,FIELD,"OLD")=$G(OLDVAL(SUB))
  1.  .S ^XTMP(NAME,NODE,TYPE,FIELD,"NEW")=$G(NEWVAL(SUB))
  1.  S CLEAR=1,CLEAR("ALL")=1
  1.  F GTYPE="DISCHARGE","MOVEMENT","SERVICE","SERVICE46"  D
  1.  .I $D(^XTMP(NAME,NODE,GTYPE)) D
  1.  ..S SUB="" F  S SUB=$O(^XTMP(NAME,NODE,GTYPE,SUB)) Q:SUB=""!('CLEAR)  D
  1.  ...I SUB'="IENS" S CLEAR=0,CLEAR("ALL")=0
  1.  ..I CLEAR K ^XTMP(NAME,NODE,GTYPE)
  1.  ..E  S CLEAR=1
  1.  I CLEAR("ALL") D  Q
  1.  .K ^XTMP(NAME,NODE),^XTMP(NAME,"B",FILE,IEN("TOP"))
  1.  .I $O(^XTMP(NAME,0))="" K ^XTMP(NAME)
  1.  S ^XTMP(NAME,NODE,TYPE,"IENS")=IEN
  1.  S ^XTMP(NAME,NODE,"DFN")=DFN
  1.  S ^XTMP(NAME,NODE,"INTEREST DATE")=$P($G(^DGPT(IEN("TOP"),0)),U,2)
  1.  S ^XTMP(NAME,NODE,"OCCURRED DATE")=$$NOW^XLFDT
  1.  S ^XTMP(NAME,NODE,"FILE")=FILE
  1.  D INP^VADPT
  1.  Q:+$G(VAERR)
  1.  I +$G(VAIN(2))>0 S ^XTMP(NAME,NODE,"PRIMARY PROVIDER")=+VAIN(2)
  1.  I +$G(VAIN(11))>0 S ^XTMP(NAME,NODE,"ATTENDING PHYSICIAN")=+VAIN(11)
  1.  I +$G(VAIN(4))>0 D
  1.  .S INST=+$P($G(^DIC(42,+VAIN(4),0)),U,11) Q:INST=0
  1.  .S INST=+$P($G(^DG(40.8,INST,0)),U,7) Q:INST=0
  1.  I +$G(VAIN(4))=0 D
  1.  .S INST=+$P($G(^DGPT(IEN("TOP"),0)),U,3) Q:INST=0
  1.  .D F4^XUAF4(INST,.STATION) Q:$P($G(STATION),U,1)=0
  1.  .S INST=$P(STATION,U,1)
  1.  I +$G(INST)>0 S ^XTMP(NAME,NODE,"INSTITUTION")=INST
  1.  S ^XTMP(NAME,"B",FILE,IEN("TOP"))=NODE
  1.  Q
  1. ALLCLEAR(DATA) ;RETURN TRUE IF ALL NODES ARE EMPTY
  1.  N RETURN,SUB
  1.  S RETURN=1
  1.  S SUB="" F  S SUB=$O(DATA(SUB)) Q:(SUB="")!('RETURN)  D
  1.  .I $G(DATA(SUB))'="" S RETURN=0
  1.  Q RETURN
  1. GETNODE(NAME,FILE,IEN) ;RETURN A FREE NODE IN NOTIFIER DATA
  1.  N RETURN
  1.  S RETURN=$G(^XTMP(NAME,"B",FILE,IEN))
  1.  I RETURN="" F  S RETURN=$J_" "_$$NOW^XLFDT Q:'$D(^XTMP(NAME,RETURN))  H 1
  1.  S ^XTMP(NAME,0)=$$FMADD^XLFDT(DT,5)_U_DT_U_"PTF ICD NOTIFIER DATA"
  1.  Q RETURN
  1. GETFIELD(TYPE,SUB) ;RETURN SUBSCRIPT FIELD NAME
  1.  N RETURN,NUMBER
  1.  S RETURN=""
  1.  I TYPE="DISCHARGE" D
  1.  .I SUB=3 S RETURN="PDX" Q
  1.  .I SUB>3,SUB<28 S NUMBER=SUB-3,RETURN="SDX"_$S(NUMBER<10:"0",1:"")_NUMBER Q
  1.  .I SUB=28 S RETURN="PDX-P1986"
  1.  I TYPE="MOVEMENT" D
  1.  .I SUB>1,SUB<27 S NUMBER=SUB-1,RETURN="DX"_$S(NUMBER<10:"0",1:"")_NUMBER
  1.  I TYPE="SERVICE",SUB=2 S RETURN="PDX"
  1.  I TYPE="SERVICE46" D
  1.  .I SUB=3 S RETURN="PDX" Q
  1.  .I SUB>3,SUB<11 S NUMBER=SUB-3,RETURN="SDX"_$S(NUMBER<10:"0",1:"")_NUMBER
  1.  Q RETURN
  1.  ;
  1.  ;=============================================
  1.  ;QUEUE DATA CHANGE MESSAGES WHEN AN ICD
  1.  ;PROCEDURE CODE IS RECORDED, EDITED OR DELETED
  1. NOTIFYP(OLDVAL,NEWVAL,DA,FILE,TYPE,ACTION) ; 
  1.  ;ALLOW THE SET CALL TO STORE THE DATA WHEN EDITING AN ENTRY
  1.  ;DO NOT EXECUTE DURING A PRE-/POST-INSTALL OF THE RELATED INDEXES
  1.  I (($G(ACTION)="KILL")&($G(NEWVAL(1))'=""))!($G(XPDNM)'="") Q
  1.  N IEN,DFN,RECTYPE,SUB,NAME,NODE,EXISTS,FIELD,GTYPE,CLEAR,STATION,INST
  1.  S IEN=$$IENS^DILF(.DA) Q:+IEN<1
  1.  S IEN("TOP")=$P(IEN,",",$L(IEN,",")-1),TYPE=$G(TYPE)
  1.  I TYPE="DISCHARGE" S DFN=$G(NEWVAL(1)),RECTYPE=$G(NEWVAL(2)),SUB=2
  1.  I (TYPE="PROCEDURE")!(TYPE="SURGERY") D
  1.  . S DFN=$P($G(^DGPT(IEN("TOP"),0)),U)
  1.  . S RECTYPE=$P($G(^DGPT(IEN("TOP"),0)),U,11),SUB=1
  1.  ; SKIP UNKNOWN TYPE AND CENSUS RECORDS (RECTYPE=2)
  1.  I (+$G(DFN)<1)!($G(RECTYPE)="")!($G(RECTYPE)=2)!('$D(SUB)) Q
  1.  ;
  1.  S NAME="DG PTF ICD OP NOTIFIER",NODE=$$GETNODE(NAME,FILE,IEN("TOP"))
  1.  F  S SUB=$O(OLDVAL(SUB)) Q:'+SUB  D
  1.  . I OLDVAL(SUB)=NEWVAL(SUB) Q
  1.  . S FIELD=$$GETFLD(TYPE,SUB) Q:FIELD=""
  1.  . S EXISTS=$D(^XTMP(NAME,NODE,TYPE,FIELD))
  1.  . S EXISTS("NEW")=$G(^XTMP(NAME,NODE,TYPE,FIELD,"NEW"))
  1.  . S EXISTS("OLD")=$G(^XTMP(NAME,NODE,TYPE,FIELD,"OLD"))
  1.  . ;NEW RECORD/FIELD VALUE DELETED BEFORE NOTIFICATION SENT
  1.  . I EXISTS,EXISTS("NEW")=$G(OLDVAL(SUB)),$G(NEWVAL(SUB))="",EXISTS("OLD")="" D  Q
  1.  .. K ^XTMP(NAME,NODE,TYPE,FIELD)
  1.  . I 'EXISTS S ^XTMP(NAME,NODE,TYPE,FIELD,"OLD")=$G(OLDVAL(SUB))
  1.  . S ^XTMP(NAME,NODE,TYPE,FIELD,"NEW")=$G(NEWVAL(SUB))
  1.  ;
  1.  S CLEAR=1,CLEAR("ALL")=1
  1.  F GTYPE="DISCHARGE","PROCEDURE","SURGERY"  D
  1.  . I $D(^XTMP(NAME,NODE,GTYPE)) D
  1.  .. S SUB="" F  S SUB=$O(^XTMP(NAME,NODE,GTYPE,SUB)) Q:SUB=""!('CLEAR)  D
  1.  ... I SUB'="IENS" S CLEAR=0,CLEAR("ALL")=0
  1.  .. I CLEAR K ^XTMP(NAME,NODE,GTYPE)
  1.  .. E  S CLEAR=1
  1.  I CLEAR("ALL") D  Q
  1.  . K ^XTMP(NAME,NODE),^XTMP(NAME,"B",FILE,IEN("TOP"))
  1.  . I $O(^XTMP(NAME,0))="" K ^XTMP(NAME)
  1.  ;
  1.  S ^XTMP(NAME,NODE,TYPE,"IENS")=IEN
  1.  S ^XTMP(NAME,NODE,"DFN")=DFN
  1.  S ^XTMP(NAME,NODE,"INTEREST DATE")=$P($G(^DGPT(IEN("TOP"),0)),U,2)
  1.  S ^XTMP(NAME,NODE,"OCCURRED DATE")=$$NOW^XLFDT
  1.  S ^XTMP(NAME,NODE,"FILE")=FILE
  1.  S INST=+$P($G(^DGPT(IEN("TOP"),0)),U,3) I INST'=0 D
  1.  . D F4^XUAF4(INST,.STATION) Q:$P($G(STATION),U,1)=0
  1.  . S INST=$P(STATION,U,1)
  1.  I +$G(INST)>0 S ^XTMP(NAME,NODE,"INSTITUTION")=INST
  1.  S ^XTMP(NAME,"B",FILE,IEN("TOP"))=NODE
  1.  Q
  1.  ;
  1. GETFLD(TYPE,SUB) ;RETURN SUBSCRIPT FIELD NAME
  1.  N RETURN,NUMBER
  1.  S RETURN=""
  1.  I TYPE="DISCHARGE" D
  1.  . S NUMBER=SUB-2,RETURN="OPC"_$S(NUMBER<10:"0",1:"")_NUMBER Q
  1.  I TYPE="PROCEDURE" D
  1.  . S NUMBER=SUB-1,RETURN="OPC"_$S(NUMBER<10:"0",1:"")_NUMBER
  1.  I TYPE="SURGERY" D
  1.  . S NUMBER=SUB-1,RETURN="OPC"_$S(NUMBER<10:"0",1:"")_NUMBER
  1.  Q RETURN