PXRMGECK ;SLC/AGP,JVS-GEC Utilities Cont. ;7/14/05 10:42
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
;
Q
TIUSTAT(DFN,GEC) ;Status of TIU Notes
N TIUDA,IEN,TITLE,NTTYP,STATUS,STATDA,STATUS,AUTDA,AUTHOR,DATE,DATEFM
Q:'$D(^PXRMD(801.5,"B",DFN)) 0
Q:'$D(^PXRMD(801.5,"AD",DFN,GEC)) 0
S IEN=$O(^PXRMD(801.5,"AD",DFN,GEC,0))
S TIUDA=$P($G(^PXRMD(801.5,IEN,0)),"^",4)
Q:TIUDA="" 0
Q:'$D(^TIU(8925,TIUDA,0)) 0
S NTTYP=$P($G(^TIU(8925,TIUDA,0)),"^",1)
S TITLE=$P($G(^TIU(8925.1,NTTYP,0)),"^",1)
S STATDA=$P($G(^TIU(8925,TIUDA,0)),"^",5)
S STATUS=$P($G(^TIU(8925.6,STATDA,0)),"^",1)
S AUTDA=$P($G(^TIU(8925,TIUDA,12)),"^",2) D
.I AUTDA="" S AUTHOR="unknown" Q
.S AUTHOR=$$GET1^DIQ(200,AUTDA,.01)
S DATEFM=$P($G(^TIU(8925,TIUDA,12)),"^",1) D
.I DATEFM="" S DATE="unknown" Q
.S DATE=$$FMTE^XLFDT(DATEFM,"D2")
Q 1_"^"_TITLE_":"_STATUS_":"_AUTHOR_":"_DATE
;
ACOPYDEL ;clean out ACOPY nodes
N NIEN,STATUS,STIEN,NOTEDFN,CDFN,EDT,GEC,DATE
Q:'$D(^PXRMD(801.5,"ACOPY"))
S NIEN=0 F S NIEN=$O(^PXRMD(801.5,"ACOPY",NIEN)) Q:NIEN="" D
.Q:'$D(^TIU(8925,NIEN))
.S STIEN=$P($G(^TIU(8925,NIEN,0)),"^",5)
.S STATUS=$P($G(^TIU(8925.6,STIEN,0)),"^",1)
.I STATUS="COMPLETED" K ^PXRMD(801.5,"ACOPY",NIEN)
.S NOTEDFN=$P($G(^TIU(8925,NIEN,0)),"^",2)
.S CDFN=0 F S CDFN=$O(^PXRMD(801.5,"ACOPY",NIEN,CDFN)) Q:CDFN="" D
..I NOTEDFN'=CDFN K ^PXRMD(801.5,"ACOPY",NIEN,CDFN)
S NIEN=0 F S NIEN=$O(^PXRMD(801.5,"ACOPY",NIEN)) Q:NIEN="" D
.S CDFN=0 F S CDFN=$O(^PXRMD(801.5,"ACOPY",NIEN,CDFN)) Q:CDFN="" D
..S EDT=0 F S EDT=$O(^PXRMD(801.5,"ACOPY",NIEN,CDFN,EDT)) Q:EDT="" D
...S GEC="" F S GEC=$O(^PXRMD(801.5,"ACOPY",NIEN,CDFN,EDT,GEC)) Q:GEC="" D
....S DATE=$O(^PXRMD(801.5,"ACOPY",NIEN,CDFN,EDT,GEC,0))
....I '$D(^TIU(8925,NIEN)),$$FMDIFF^XLFDT(DT,DATE,1)>1 D
.....K ^PXRMD(801.5,"ACOPY",NIEN,CDFN,EDT,GEC)
Q
;
;
REMOVE ;DELETE HEALTH FACTORS
N NODE0,NODE12,NODE812,VISIT,PKG,VAL,PCEARY
Q:'$D(HFARY)
S PCEARY="^TMP(""PXRMGECZ"",$J)"
S HFDA=0 F S HFDA=$O(HFARY(HFDA)) Q:HFDA="" D
.N NODE0,NODE12,NODE812
.S NODE0=$G(^AUPNVHF(HFDA,0))
.S NODE12=$G(^AUPNVHF(HFDA,12))
.S NODE812=$G(^AUPNVHF(HFDA,812))
.S VISIT=$P(NODE0,"^",3)
.S PKG=$P(NODE812,"^",2)
.S ^TMP("PXRMGECZ",$J,"HEALTH FACTOR",HFDA,"HEALTH FACTOR")=$P(NODE0,"^",1)
.S ^TMP("PXRMGECZ",$J,"HEALTH FACTOR",HFDA,"ENC PROVIDER")=$P(NODE12,"^",4)
.S ^TMP("PXRMGECZ",$J,"HEALTH FACTOR",HFDA,"EVENT D/T")=$P(NODE12,"^",1)
.S ^TMP("PXRMGECZ",$J,"HEALTH FACTOR",HFDA,"DELETE")=1
S VAL=$$DATA2PCE^PXAPI(PCEARY,PKG,GECT,VISIT)
K ^TMP("PXRMGECZ",$J)
;
Q
UPDATE(DFN,VISIT) ;Remove entry from 801.5 if deleted by dialog/tiu
;
N HFDA,COUNT,SOURCE,GEC1,GEC2,GEC3,GECF,ENCDT,WHICH
N HERE,NOT,DA,DIA
Q:DFN=""
;
;Delete Health Factors if not TIU document
;
S ENCDT=$O(^PXRMD(801.5,"AC",DFN,""))
Q:ENCDT=""
;
S (GEC1,GEC2,GEC3,GECF)=0
;GET IEN FOR DATA SOURCES FOR GEC
I $D(^PX(839.7,"B","GEC1")) D
.S GEC1=$O(^PX(839.7,"B","GEC1","")),WHICH(GEC1)="GEC1",NOT("GEC1")=""
I $D(^PX(839.7,"B","GEC2")) D
.S GEC2=$O(^PX(839.7,"B","GEC2","")),WHICH(GEC2)="GEC2",NOT("GEC2")=""
I $D(^PX(839.7,"B","GEC3")) D
.S GEC3=$O(^PX(839.7,"B","GEC3","")),WHICH(GEC3)="GEC3",NOT("GEC3")=""
I $D(^PX(839.7,"B","GECF")) D
.S GECF=$O(^PX(839.7,"B","GECF","")),WHICH(GECF)="GECF",NOT("GECF")=""
;
;
S COUNT=0
S HFDA="" F S HFDA=$O(^AUPNVHF("C",DFN,HFDA)) Q:HFDA="" D
.I $D(^AUPNVHF(HFDA,12)) D
..I $P($G(^AUPNVHF(HFDA,12)),"^",1)=ENCDT D
...S SOURCE=$P($G(^AUPNVHF(HFDA,812)),"^",3)
...Q:SOURCE=""
...I (SOURCE=$G(GEC1))!(SOURCE=$G(GEC2))!(SOURCE=$G(GEC3))!(SOURCE=$G(GECF)) D
....S HERE($G(WHICH(SOURCE)))=""
....K NOT($G(WHICH(SOURCE)))
....S COUNT=COUNT+1
S DIA="" F S DIA=$O(NOT(DIA)) Q:DIA="" D
.S DA=$O(^PXRMD(801.5,"AD",DFN,DIA,0))
.Q:DA=""
.S ^PXRMD(801.5,"ACOPY",DFN,ENCDT,DIA)=$P($G(^PXRMD(801.5,DA,0)),"^",4)
.S DIK="^PXRMD(801.5," D ^DIK
Q
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMGECK 3967 printed Oct 16, 2024@17:46:33 Page 2
PXRMGECK ;SLC/AGP,JVS-GEC Utilities Cont. ;7/14/05 10:42
+1 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+2 ;
+3 QUIT
TIUSTAT(DFN,GEC) ;Status of TIU Notes
+1 NEW TIUDA,IEN,TITLE,NTTYP,STATUS,STATDA,STATUS,AUTDA,AUTHOR,DATE,DATEFM
+2 if '$DATA(^PXRMD(801.5,"B",DFN))
QUIT 0
+3 if '$DATA(^PXRMD(801.5,"AD",DFN,GEC))
QUIT 0
+4 SET IEN=$ORDER(^PXRMD(801.5,"AD",DFN,GEC,0))
+5 SET TIUDA=$PIECE($GET(^PXRMD(801.5,IEN,0)),"^",4)
+6 if TIUDA=""
QUIT 0
+7 if '$DATA(^TIU(8925,TIUDA,0))
QUIT 0
+8 SET NTTYP=$PIECE($GET(^TIU(8925,TIUDA,0)),"^",1)
+9 SET TITLE=$PIECE($GET(^TIU(8925.1,NTTYP,0)),"^",1)
+10 SET STATDA=$PIECE($GET(^TIU(8925,TIUDA,0)),"^",5)
+11 SET STATUS=$PIECE($GET(^TIU(8925.6,STATDA,0)),"^",1)
+12 SET AUTDA=$PIECE($GET(^TIU(8925,TIUDA,12)),"^",2)
Begin DoDot:1
+13 IF AUTDA=""
SET AUTHOR="unknown"
QUIT
+14 SET AUTHOR=$$GET1^DIQ(200,AUTDA,.01)
End DoDot:1
+15 SET DATEFM=$PIECE($GET(^TIU(8925,TIUDA,12)),"^",1)
Begin DoDot:1
+16 IF DATEFM=""
SET DATE="unknown"
QUIT
+17 SET DATE=$$FMTE^XLFDT(DATEFM,"D2")
End DoDot:1
+18 QUIT 1_"^"_TITLE_":"_STATUS_":"_AUTHOR_":"_DATE
+19 ;
ACOPYDEL ;clean out ACOPY nodes
+1 NEW NIEN,STATUS,STIEN,NOTEDFN,CDFN,EDT,GEC,DATE
+2 if '$DATA(^PXRMD(801.5,"ACOPY"))
QUIT
+3 SET NIEN=0
FOR
SET NIEN=$ORDER(^PXRMD(801.5,"ACOPY",NIEN))
if NIEN=""
QUIT
Begin DoDot:1
+4 if '$DATA(^TIU(8925,NIEN))
QUIT
+5 SET STIEN=$PIECE($GET(^TIU(8925,NIEN,0)),"^",5)
+6 SET STATUS=$PIECE($GET(^TIU(8925.6,STIEN,0)),"^",1)
+7 IF STATUS="COMPLETED"
KILL ^PXRMD(801.5,"ACOPY",NIEN)
+8 SET NOTEDFN=$PIECE($GET(^TIU(8925,NIEN,0)),"^",2)
+9 SET CDFN=0
FOR
SET CDFN=$ORDER(^PXRMD(801.5,"ACOPY",NIEN,CDFN))
if CDFN=""
QUIT
Begin DoDot:2
+10 IF NOTEDFN'=CDFN
KILL ^PXRMD(801.5,"ACOPY",NIEN,CDFN)
End DoDot:2
End DoDot:1
+11 SET NIEN=0
FOR
SET NIEN=$ORDER(^PXRMD(801.5,"ACOPY",NIEN))
if NIEN=""
QUIT
Begin DoDot:1
+12 SET CDFN=0
FOR
SET CDFN=$ORDER(^PXRMD(801.5,"ACOPY",NIEN,CDFN))
if CDFN=""
QUIT
Begin DoDot:2
+13 SET EDT=0
FOR
SET EDT=$ORDER(^PXRMD(801.5,"ACOPY",NIEN,CDFN,EDT))
if EDT=""
QUIT
Begin DoDot:3
+14 SET GEC=""
FOR
SET GEC=$ORDER(^PXRMD(801.5,"ACOPY",NIEN,CDFN,EDT,GEC))
if GEC=""
QUIT
Begin DoDot:4
+15 SET DATE=$ORDER(^PXRMD(801.5,"ACOPY",NIEN,CDFN,EDT,GEC,0))
+16 IF '$DATA(^TIU(8925,NIEN))
IF $$FMDIFF^XLFDT(DT,DATE,1)>1
Begin DoDot:5
+17 KILL ^PXRMD(801.5,"ACOPY",NIEN,CDFN,EDT,GEC)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
+20 ;
REMOVE ;DELETE HEALTH FACTORS
+1 NEW NODE0,NODE12,NODE812,VISIT,PKG,VAL,PCEARY
+2 if '$DATA(HFARY)
QUIT
+3 SET PCEARY="^TMP(""PXRMGECZ"",$J)"
+4 SET HFDA=0
FOR
SET HFDA=$ORDER(HFARY(HFDA))
if HFDA=""
QUIT
Begin DoDot:1
+5 NEW NODE0,NODE12,NODE812
+6 SET NODE0=$GET(^AUPNVHF(HFDA,0))
+7 SET NODE12=$GET(^AUPNVHF(HFDA,12))
+8 SET NODE812=$GET(^AUPNVHF(HFDA,812))
+9 SET VISIT=$PIECE(NODE0,"^",3)
+10 SET PKG=$PIECE(NODE812,"^",2)
+11 SET ^TMP("PXRMGECZ",$JOB,"HEALTH FACTOR",HFDA,"HEALTH FACTOR")=$PIECE(NODE0,"^",1)
+12 SET ^TMP("PXRMGECZ",$JOB,"HEALTH FACTOR",HFDA,"ENC PROVIDER")=$PIECE(NODE12,"^",4)
+13 SET ^TMP("PXRMGECZ",$JOB,"HEALTH FACTOR",HFDA,"EVENT D/T")=$PIECE(NODE12,"^",1)
+14 SET ^TMP("PXRMGECZ",$JOB,"HEALTH FACTOR",HFDA,"DELETE")=1
End DoDot:1
+15 SET VAL=$$DATA2PCE^PXAPI(PCEARY,PKG,GECT,VISIT)
+16 KILL ^TMP("PXRMGECZ",$JOB)
+17 ;
+18 QUIT
UPDATE(DFN,VISIT) ;Remove entry from 801.5 if deleted by dialog/tiu
+1 ;
+2 NEW HFDA,COUNT,SOURCE,GEC1,GEC2,GEC3,GECF,ENCDT,WHICH
+3 NEW HERE,NOT,DA,DIA
+4 if DFN=""
QUIT
+5 ;
+6 ;Delete Health Factors if not TIU document
+7 ;
+8 SET ENCDT=$ORDER(^PXRMD(801.5,"AC",DFN,""))
+9 if ENCDT=""
QUIT
+10 ;
+11 SET (GEC1,GEC2,GEC3,GECF)=0
+12 ;GET IEN FOR DATA SOURCES FOR GEC
+13 IF $DATA(^PX(839.7,"B","GEC1"))
Begin DoDot:1
+14 SET GEC1=$ORDER(^PX(839.7,"B","GEC1",""))
SET WHICH(GEC1)="GEC1"
SET NOT("GEC1")=""
End DoDot:1
+15 IF $DATA(^PX(839.7,"B","GEC2"))
Begin DoDot:1
+16 SET GEC2=$ORDER(^PX(839.7,"B","GEC2",""))
SET WHICH(GEC2)="GEC2"
SET NOT("GEC2")=""
End DoDot:1
+17 IF $DATA(^PX(839.7,"B","GEC3"))
Begin DoDot:1
+18 SET GEC3=$ORDER(^PX(839.7,"B","GEC3",""))
SET WHICH(GEC3)="GEC3"
SET NOT("GEC3")=""
End DoDot:1
+19 IF $DATA(^PX(839.7,"B","GECF"))
Begin DoDot:1
+20 SET GECF=$ORDER(^PX(839.7,"B","GECF",""))
SET WHICH(GECF)="GECF"
SET NOT("GECF")=""
End DoDot:1
+21 ;
+22 ;
+23 SET COUNT=0
+24 SET HFDA=""
FOR
SET HFDA=$ORDER(^AUPNVHF("C",DFN,HFDA))
if HFDA=""
QUIT
Begin DoDot:1
+25 IF $DATA(^AUPNVHF(HFDA,12))
Begin DoDot:2
+26 IF $PIECE($GET(^AUPNVHF(HFDA,12)),"^",1)=ENCDT
Begin DoDot:3
+27 SET SOURCE=$PIECE($GET(^AUPNVHF(HFDA,812)),"^",3)
+28 if SOURCE=""
QUIT
+29 IF (SOURCE=$GET(GEC1))!(SOURCE=$GET(GEC2))!(SOURCE=$GET(GEC3))!(SOURCE=$GET(GECF))
Begin DoDot:4
+30 SET HERE($GET(WHICH(SOURCE)))=""
+31 KILL NOT($GET(WHICH(SOURCE)))
+32 SET COUNT=COUNT+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+33 SET DIA=""
FOR
SET DIA=$ORDER(NOT(DIA))
if DIA=""
QUIT
Begin DoDot:1
+34 SET DA=$ORDER(^PXRMD(801.5,"AD",DFN,DIA,0))
+35 if DA=""
QUIT
+36 SET ^PXRMD(801.5,"ACOPY",DFN,ENCDT,DIA)=$PIECE($GET(^PXRMD(801.5,DA,0)),"^",4)
+37 SET DIK="^PXRMD(801.5,"
DO ^DIK
End DoDot:1
+38 QUIT
+39 ;
+40 ;
