- 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 Feb 19, 2025@00:09:55 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