TIUPP3 ;SLC/DJP - Patient Posting Cover Sheet API ; 5-JAN-2000 12:38:05
;;1.0;TEXT INTEGRATION UTILITIES;**4,54,80**;Jun 20, 1997
ENCOVER(DFN) ; Supports CWAD Display.
N TIUPP K ^TMP("TIUPPCV",$J)
I +$G(DFN)'>0 S MSG="-1^DFN required." Q
D PTPLKP I TIUPP("DATA")="" S MSG="-1^No Patient Postings on file" Q
S MSG="0^Patient Postings on file"
Q
;
PTPLKP ;Lookup and listing of Patient Posting indicators
N CTR,GMRARXN,PTP,TIUCN,TIUCW,TIUAR,TIUSTS
D DOCDEF S TIUPP("DATA")="",CTR=0
D EN1^GMRAOR1(DFN,"GMRARXN")
I $G(GMRARXN) D D BLDG(.PTP,.CTR)
.S PTP("IEN")="",PTP("ACRN")="A",PTP("CN")="ALLERGIES"
.S PTP("MOD")="Known allergies",PTP("DATE")=""
F TIUSTS=7,8 D
.I $D(^TIU(8925,"ADCPT",+DFN,TIUCN,TIUSTS)) S PTP("ACRN")="C",PTP("CN")="CRISIS NOTE" D BUILD(TIUCN,TIUSTS,.PTP,.CTR)
.I $D(^TIU(8925,"ADCPT",+DFN,TIUCW,TIUSTS)) S PTP("ACRN")="W",PTP("CN")="CLINICAL WARNING" D BUILD(TIUCW,TIUSTS,.PTP,.CTR)
.I $D(^TIU(8925,"ADCPT",+DFN,TIUAR,TIUSTS)) S PTP("ACRN")="D",PTP("CN")="ADVANCE DIRECTIVE" D BUILD(TIUAR,TIUSTS,.PTP,.CTR)
Q
;
BUILD(TYPE,STATUS,PTP,CTR) ;Sets PTP Array elements for BLDG
N TIUDT S TIUDT=0
F S TIUDT=$O(^TIU(8925,"ADCPT",+DFN,TYPE,STATUS,TIUDT)) Q:+TIUDT'>0 D
.N IEN S IEN=0
.F S IEN=$O(^TIU(8925,"ADCPT",+DFN,TYPE,STATUS,TIUDT,IEN)) Q:+IEN'>0 D
..S PTP("IEN")=IEN
..S PTP("TITLE")=$$PNAME^TIULC1(+$G(^TIU(8925,IEN,0)))
..S PTP("MOD")=$P($G(^TIU(8925,IEN,17)),U)
..S PTP("DATE")=9999999-TIUDT
..D BLDG(.PTP,.CTR)
Q
;
BLDG(PTP,CTR) ;Build ^TMP("TIUPPCV",$J,
;IEN^Acronym^Category Name^Optional Modifier^Date/Time^Optional Addendum
N TIUREC
S TIUPP("DATA")=TIUPP("DATA")_PTP("ACRN")
S CTR=CTR+1,TIUREC=PTP("IEN")_U_PTP("ACRN")_U_$S($L($G(PTP("TITLE"))):$G(PTP("TITLE")),1:PTP("CN"))_U_PTP("MOD")_U_PTP("DATE")
I PTP("ACRN")'="A" S TIUREC=TIUREC_U_$$GETADD(PTP("IEN"))
S ^TMP("TIUPPCV",$J,CTR)=TIUREC
Q
;
GETADD(TIUDA) ;Gets most recent addendum of a posting
N ADD,TIUY,TIUD0,TIUDT S TIUY=""
S ADD="",ADD=$O(^TIU(8925,"DAD",TIUDA,ADD),-1) G:+ADD'>0 GETADX
S TIUD0=$G(^TIU(8925,ADD,0))
I $S($P(TIUD0,U,5)=7:0,$P(TIUD0,U,5)=8:0,1:1) G GETADX
S TIUDT=$P($G(^TIU(8925,ADD,12)),U) G:'+TIUDT GETADX
S TIUY=" (addendum "_$$DATE^TIULS(TIUDT,"MM/DD/YY HR:MIN")_")"
GETADX Q TIUY
;
DOCDEF ;Sets IENs for lookup on specific Document Types/Status
N TIUDC,TIUX,TIUST
S TIUX="CLINICAL WARNING"
S TIUDC=0 F S TIUDC=$O(^TIU(8925.1,"B",TIUX,TIUDC)) Q:+TIUDC'>0!+$G(TIUCW) D
. I $P($G(^TIU(8925.1,+TIUDC,0)),U,4)="DC" S TIUCW=+TIUDC
S TIUX="CRISIS NOTE"
S TIUDC=0 F S TIUDC=$O(^TIU(8925.1,"B",TIUX,TIUDC)) Q:+TIUDC'>0!+$G(TIUCN) D
. I $P($G(^TIU(8925.1,+TIUDC,0)),U,4)="DC" S TIUCN=+TIUDC
S TIUX="ADVANCE DIRECTIVE"
S TIUDC=0 F S TIUDC=$O(^TIU(8925.1,"B",TIUX,TIUDC)) Q:+TIUDC'>0!+$G(TIUAR) D
. I $P($G(^TIU(8925.1,+TIUDC,0)),U,4)="DC" S TIUAR=+TIUDC
S:'$D(TIUCW) TIUCW=0
S:'$D(TIUCN) TIUCN=0
S:'$D(TIUAR) TIUAR=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPP3 2950 printed Dec 13, 2024@02:43:26 Page 2
TIUPP3 ;SLC/DJP - Patient Posting Cover Sheet API ; 5-JAN-2000 12:38:05
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**4,54,80**;Jun 20, 1997
ENCOVER(DFN) ; Supports CWAD Display.
+1 NEW TIUPP
KILL ^TMP("TIUPPCV",$JOB)
+2 IF +$GET(DFN)'>0
SET MSG="-1^DFN required."
QUIT
+3 DO PTPLKP
IF TIUPP("DATA")=""
SET MSG="-1^No Patient Postings on file"
QUIT
+4 SET MSG="0^Patient Postings on file"
+5 QUIT
+6 ;
PTPLKP ;Lookup and listing of Patient Posting indicators
+1 NEW CTR,GMRARXN,PTP,TIUCN,TIUCW,TIUAR,TIUSTS
+2 DO DOCDEF
SET TIUPP("DATA")=""
SET CTR=0
+3 DO EN1^GMRAOR1(DFN,"GMRARXN")
+4 IF $GET(GMRARXN)
Begin DoDot:1
+5 SET PTP("IEN")=""
SET PTP("ACRN")="A"
SET PTP("CN")="ALLERGIES"
+6 SET PTP("MOD")="Known allergies"
SET PTP("DATE")=""
End DoDot:1
DO BLDG(.PTP,.CTR)
+7 FOR TIUSTS=7,8
Begin DoDot:1
+8 IF $DATA(^TIU(8925,"ADCPT",+DFN,TIUCN,TIUSTS))
SET PTP("ACRN")="C"
SET PTP("CN")="CRISIS NOTE"
DO BUILD(TIUCN,TIUSTS,.PTP,.CTR)
+9 IF $DATA(^TIU(8925,"ADCPT",+DFN,TIUCW,TIUSTS))
SET PTP("ACRN")="W"
SET PTP("CN")="CLINICAL WARNING"
DO BUILD(TIUCW,TIUSTS,.PTP,.CTR)
+10 IF $DATA(^TIU(8925,"ADCPT",+DFN,TIUAR,TIUSTS))
SET PTP("ACRN")="D"
SET PTP("CN")="ADVANCE DIRECTIVE"
DO BUILD(TIUAR,TIUSTS,.PTP,.CTR)
End DoDot:1
+11 QUIT
+12 ;
BUILD(TYPE,STATUS,PTP,CTR) ;Sets PTP Array elements for BLDG
+1 NEW TIUDT
SET TIUDT=0
+2 FOR
SET TIUDT=$ORDER(^TIU(8925,"ADCPT",+DFN,TYPE,STATUS,TIUDT))
if +TIUDT'>0
QUIT
Begin DoDot:1
+3 NEW IEN
SET IEN=0
+4 FOR
SET IEN=$ORDER(^TIU(8925,"ADCPT",+DFN,TYPE,STATUS,TIUDT,IEN))
if +IEN'>0
QUIT
Begin DoDot:2
+5 SET PTP("IEN")=IEN
+6 SET PTP("TITLE")=$$PNAME^TIULC1(+$GET(^TIU(8925,IEN,0)))
+7 SET PTP("MOD")=$PIECE($GET(^TIU(8925,IEN,17)),U)
+8 SET PTP("DATE")=9999999-TIUDT
+9 DO BLDG(.PTP,.CTR)
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
BLDG(PTP,CTR) ;Build ^TMP("TIUPPCV",$J,
+1 ;IEN^Acronym^Category Name^Optional Modifier^Date/Time^Optional Addendum
+2 NEW TIUREC
+3 SET TIUPP("DATA")=TIUPP("DATA")_PTP("ACRN")
+4 SET CTR=CTR+1
SET TIUREC=PTP("IEN")_U_PTP("ACRN")_U_$SELECT($LENGTH($GET(PTP("TITLE"))):$GET(PTP("TITLE")),1:PTP("CN"))_U_PTP("MOD")_U_PTP("DATE")
+5 IF PTP("ACRN")'="A"
SET TIUREC=TIUREC_U_$$GETADD(PTP("IEN"))
+6 SET ^TMP("TIUPPCV",$JOB,CTR)=TIUREC
+7 QUIT
+8 ;
GETADD(TIUDA) ;Gets most recent addendum of a posting
+1 NEW ADD,TIUY,TIUD0,TIUDT
SET TIUY=""
+2 SET ADD=""
SET ADD=$ORDER(^TIU(8925,"DAD",TIUDA,ADD),-1)
if +ADD'>0
GOTO GETADX
+3 SET TIUD0=$GET(^TIU(8925,ADD,0))
+4 IF $SELECT($PIECE(TIUD0,U,5)=7:0,$PIECE(TIUD0,U,5)=8:0,1:1)
GOTO GETADX
+5 SET TIUDT=$PIECE($GET(^TIU(8925,ADD,12)),U)
if '+TIUDT
GOTO GETADX
+6 SET TIUY=" (addendum "_$$DATE^TIULS(TIUDT,"MM/DD/YY HR:MIN")_")"
GETADX QUIT TIUY
+1 ;
DOCDEF ;Sets IENs for lookup on specific Document Types/Status
+1 NEW TIUDC,TIUX,TIUST
+2 SET TIUX="CLINICAL WARNING"
+3 SET TIUDC=0
FOR
SET TIUDC=$ORDER(^TIU(8925.1,"B",TIUX,TIUDC))
if +TIUDC'>0!+$GET(TIUCW)
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^TIU(8925.1,+TIUDC,0)),U,4)="DC"
SET TIUCW=+TIUDC
End DoDot:1
+5 SET TIUX="CRISIS NOTE"
+6 SET TIUDC=0
FOR
SET TIUDC=$ORDER(^TIU(8925.1,"B",TIUX,TIUDC))
if +TIUDC'>0!+$GET(TIUCN)
QUIT
Begin DoDot:1
+7 IF $PIECE($GET(^TIU(8925.1,+TIUDC,0)),U,4)="DC"
SET TIUCN=+TIUDC
End DoDot:1
+8 SET TIUX="ADVANCE DIRECTIVE"
+9 SET TIUDC=0
FOR
SET TIUDC=$ORDER(^TIU(8925.1,"B",TIUX,TIUDC))
if +TIUDC'>0!+$GET(TIUAR)
QUIT
Begin DoDot:1
+10 IF $PIECE($GET(^TIU(8925.1,+TIUDC,0)),U,4)="DC"
SET TIUAR=+TIUDC
End DoDot:1
+11 if '$DATA(TIUCW)
SET TIUCW=0
+12 if '$DATA(TIUCN)
SET TIUCN=0
+13 if '$DATA(TIUAR)
SET TIUAR=0
+14 QUIT
