109 lines
4.6 KiB
Mathematica
109 lines
4.6 KiB
Mathematica
|
WVPROF2 ;HCIOFO/FT,JR-DISPLAY PATIENT PROFILE; ;5/27/99 16:48
|
||
|
|
;;1.0;WOMEN'S HEALTH;**7**;Sep 30, 1998
|
||
|
|
;; Original routine created by IHS/ANMC/MWR
|
||
|
|
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
|
||
|
|
;; RETRIEVE AND SORT PROCEDURES, NOTIFICATIONS, PAP REGIMENS,
|
||
|
|
;; AND PREGNANCIES FOR PATIENT PROFILE. CALLED BY WVPROF.
|
||
|
|
;
|
||
|
|
SORT ;EP
|
||
|
|
;---> SORT AND STORE ARRAY IN ^TMP("WV",$J
|
||
|
|
;
|
||
|
|
K ^TMP("WV",$J)
|
||
|
|
;---> WVBEGDT1=ONE SECOND BEFORE BEGIN DATE.
|
||
|
|
;---> WVENDDT1=THE LAST SECOND OF END DATE.
|
||
|
|
;S WVBEGDT1=WVBEGDT-.0001,WVENDDT1=WVENDDT+.9999 ;---> XDATES
|
||
|
|
;
|
||
|
|
D PATVARS^WVUTL3(WVDFN)
|
||
|
|
;
|
||
|
|
;*******************
|
||
|
|
;---> GET PROCEDURES
|
||
|
|
S WVIEN=0
|
||
|
|
F S WVIEN=$O(^WV(790.1,"C",WVDFN,WVIEN)) Q:'WVIEN D
|
||
|
|
.;---> SET Y=THE ZERO NODE FOR THIS PROCEDURE.
|
||
|
|
.S Y=^WV(790.1,WVIEN,0)
|
||
|
|
.;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
|
||
|
|
.Q:WVERRORS&($P(Y,U,5)=8)
|
||
|
|
.;---> QUIT IF NOT WITHIN DATE RANGE.
|
||
|
|
.S (WVDATE,WVDATE1)=$P(Y,U,12)
|
||
|
|
.;Q:WVDATE'>WVBEGDT1!(WVDATE>WVENDDT1) ;---> XDATES
|
||
|
|
.S WVDATE1=$$SLDT2^WVUTL5(WVDATE1)
|
||
|
|
.S WVACC=$P(Y,U) ;---> ACCESSION#
|
||
|
|
.S WVPCD=$P(^WV(790.2,$P(Y,U,4),0),U,2) ;---> PROC TYPE
|
||
|
|
.S WVSTAT=$$STATUS^WVUTL4 ;---> STATUS
|
||
|
|
.S WVDIAG=$$DIAG^WVUTL4($P(Y,U,5)) ;---> RESULT/DIAG
|
||
|
|
.S WVPROV=$P(Y,U,7) D ;---> PROVIDER
|
||
|
|
..I 'WVPROV S WVPROV="NOT ENTERED" Q
|
||
|
|
..S WVPROV=$P($$GET1^DIQ(200,WVPROV,.01,"E"),",")
|
||
|
|
.;---> FOR PROCEDURES, SET 1ST PIECE AND 6TH SUBSCRIPT=1.
|
||
|
|
.S X=1_U_U_U_WVDATE1_U_WVPCD_U_WVACC_U_WVDIAG
|
||
|
|
.S X=X_U_WVPROV_U_WVSTAT_U_WVIEN
|
||
|
|
.S ^TMP("WV",$J,1,9999999.9999-WVDATE,WVACC,1,WVIEN)=X Q
|
||
|
|
;
|
||
|
|
;**********************
|
||
|
|
;---> GET NOTIFICATIONS
|
||
|
|
Q:'WVD
|
||
|
|
S WVIEN=0
|
||
|
|
F S WVIEN=$O(^WV(790.4,"B",WVDFN,WVIEN)) Q:'WVIEN D
|
||
|
|
.S Y=^WV(790.4,WVIEN,0)
|
||
|
|
.;---> QUIT IF NOT WITHIN DATE RANGE. WVDATE1 PRESERVES NOTIF DATE.
|
||
|
|
.S (WVDATE,WVDATE1)=$P(Y,U,2)
|
||
|
|
.;Q:WVDATE'>WVBEGDT1!(WVDATE>WVENDDT1) ;---> XDATE
|
||
|
|
.S WVDATE1=$$SLDT2^WVUTL5(WVDATE1)
|
||
|
|
.S WVACC=$P(Y,U,6) D ;---> ACCESSION#
|
||
|
|
..I WVACC="" S WVACC="NO ACC#" Q
|
||
|
|
..;---> IF THIS NOTIFICATION PERTAINS TO A PROCEDURE (I.E., IT
|
||
|
|
..;---> HAS AN ACCESSION#), RESET ITS DATE SO THAT IT WILL COLLATE
|
||
|
|
..;---> UNDER ITS PROCEDURE IN THE DISPLAY.
|
||
|
|
..S WVACC=$P(^WV(790.1,WVACC,0),U),WVDATE=$P(^(0),U,12)
|
||
|
|
.S WVSTAT=$$STATUS^WVUTL4 ;---> STATUS
|
||
|
|
.S WVTYPE=$P(Y,U,3) D ;---> TYPE
|
||
|
|
..I WVTYPE="" S WVTYPE="NOT ENTERED" Q
|
||
|
|
..S WVTYPE=$P(^WV(790.403,WVTYPE,0),U)
|
||
|
|
.S WVPURP=$P(Y,U,4) D ;---> PURPOSE
|
||
|
|
..I WVPURP="" S WVPURP="NOT ENTERED" Q
|
||
|
|
..S WVPURP=$P(^WV(790.404,WVPURP,0),U)
|
||
|
|
.S WVOUT=$P(Y,U,5) D ;---> OUTCOME
|
||
|
|
..I WVOUT="" S WVOUT="NOT ENTERED" Q
|
||
|
|
..S WVOUT=$P(^WV(790.405,WVOUT,0),U)
|
||
|
|
.;---> FOR NOTIFICATIONS, SET 1ST PIECE AND 6TH SUBSCRIPT=2.
|
||
|
|
.;S X=2_U_WVCHRT_U_WVNAME_U_WVDATE1_U_WVACC_U_WVTYPE_U_WVPURP
|
||
|
|
.S X=2_U_U_U_WVDATE1_U_WVACC_U_WVTYPE_U_WVPURP
|
||
|
|
.S X=X_U_WVOUT_U_WVSTAT_U_WVIEN
|
||
|
|
.S ^TMP("WV",$J,1,9999999.9999-WVDATE,WVACC,2,WVIEN)=X Q
|
||
|
|
;
|
||
|
|
;**********************
|
||
|
|
;---> GET PAP REGIMENS
|
||
|
|
S WVIEN=0
|
||
|
|
F S WVIEN=$O(^WV(790.04,"C",WVDFN,WVIEN)) Q:'WVIEN D
|
||
|
|
.;---> SET Y=THE ZERO NODE FOR THIS PAP REGIMEN LOG ENTRY.
|
||
|
|
.S Y=^WV(790.04,WVIEN,0)
|
||
|
|
.;---> PIECE 1=START DATE FOR THE PAP REGIMEN.
|
||
|
|
.S (WVDATE,WVDATE1)=$P(Y,U) ;---> DATE
|
||
|
|
.;---> QUIT IF NOT WITHIN DATE RANGE.
|
||
|
|
.;Q:WVDATE'>WVBEGDT1!(WVDATE>WVENDDT1) ;---> XDATES
|
||
|
|
.S WVDATE1=$$SLDT2^WVUTL5(WVDATE1)
|
||
|
|
.S WVPAPRG1=$$PAPRG1^WVUTL1($P(Y,U,3)) ;---> PAP REGIMEN
|
||
|
|
.;---> FOR PAP REGIMENS, SET 1ST PIECE AND 6TH SUBSCRIPT=3.
|
||
|
|
.;S X=3_U_WVCHRT_U_WVNAME_U_WVDATE1_U_WVPAPRG1
|
||
|
|
.S X=3_U_U_U_WVDATE1_U_WVPAPRG1
|
||
|
|
.S ^TMP("WV",$J,1,9999999.9999-WVDATE,1,3,WVIEN)=X Q
|
||
|
|
;
|
||
|
|
;**********************
|
||
|
|
;---> GET PREGNANCIES
|
||
|
|
S WVIEN=0
|
||
|
|
F S WVIEN=$O(^WV(790.05,"C",WVDFN,WVIEN)) Q:'WVIEN D
|
||
|
|
.;---> SET Y=THE ZERO NODE FOR THIS PREGNANCY LOG ENTRY.
|
||
|
|
.S Y=^WV(790.05,WVIEN,0)
|
||
|
|
.;---> PIECE 1=DATE PREGNANCY LOG ENTRY WAS MADE.
|
||
|
|
.S (WVDATE,WVDATE1)=$P(Y,U) ;---> DATE
|
||
|
|
.;---> QUIT IF NOT WITHIN DATE RANGE.
|
||
|
|
.;Q:WVDATE'>WVBEGDT1!(WVDATE>WVENDDT1) ;---> XDATES
|
||
|
|
.S WVDATE1=$$SLDT2^WVUTL5(WVDATE1)
|
||
|
|
.S WVPSTAT=$S($P(Y,U,3):"PREGNANT",1:"NOT PREGNANT") ;---> PREG STATUS
|
||
|
|
.S WVEDCL=$S(X:$$SLDT2^WVUTL5($P(Y,U,4)),1:"") ;---> EDC
|
||
|
|
.;---> FOR PREGNANCIES, SET 1ST PIECE AND 6TH SUBSCRIPT=4.
|
||
|
|
.;S X=4_U_WVCHRT_U_WVNAME_U_WVDATE1_U_WVPSTAT_U_WVEDCL
|
||
|
|
.S X=4_U_U_U_WVDATE1_U_WVPSTAT_U_WVEDCL
|
||
|
|
.S ^TMP("WV",$J,1,9999999.9999-WVDATE,1,4,WVIEN)=X Q
|
||
|
|
Q
|