| 1 | WVPROF2 ;HCIOFO/FT,JR-DISPLAY PATIENT PROFILE; ;5/27/99 16:48
|
|---|
| 2 | ;;1.0;WOMEN'S HEALTH;**7**;Sep 30, 1998
|
|---|
| 3 | ;; Original routine created by IHS/ANMC/MWR
|
|---|
| 4 | ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
|
|---|
| 5 | ;; RETRIEVE AND SORT PROCEDURES, NOTIFICATIONS, PAP REGIMENS,
|
|---|
| 6 | ;; AND PREGNANCIES FOR PATIENT PROFILE. CALLED BY WVPROF.
|
|---|
| 7 | ;
|
|---|
| 8 | SORT ;EP
|
|---|
| 9 | ;---> SORT AND STORE ARRAY IN ^TMP("WV",$J
|
|---|
| 10 | ;
|
|---|
| 11 | K ^TMP("WV",$J)
|
|---|
| 12 | ;---> WVBEGDT1=ONE SECOND BEFORE BEGIN DATE.
|
|---|
| 13 | ;---> WVENDDT1=THE LAST SECOND OF END DATE.
|
|---|
| 14 | ;S WVBEGDT1=WVBEGDT-.0001,WVENDDT1=WVENDDT+.9999 ;---> XDATES
|
|---|
| 15 | ;
|
|---|
| 16 | D PATVARS^WVUTL3(WVDFN)
|
|---|
| 17 | ;
|
|---|
| 18 | ;*******************
|
|---|
| 19 | ;---> GET PROCEDURES
|
|---|
| 20 | S WVIEN=0
|
|---|
| 21 | F S WVIEN=$O(^WV(790.1,"C",WVDFN,WVIEN)) Q:'WVIEN D
|
|---|
| 22 | .;---> SET Y=THE ZERO NODE FOR THIS PROCEDURE.
|
|---|
| 23 | .S Y=^WV(790.1,WVIEN,0)
|
|---|
| 24 | .;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
|
|---|
| 25 | .Q:WVERRORS&($P(Y,U,5)=8)
|
|---|
| 26 | .;---> QUIT IF NOT WITHIN DATE RANGE.
|
|---|
| 27 | .S (WVDATE,WVDATE1)=$P(Y,U,12)
|
|---|
| 28 | .;Q:WVDATE'>WVBEGDT1!(WVDATE>WVENDDT1) ;---> XDATES
|
|---|
| 29 | .S WVDATE1=$$SLDT2^WVUTL5(WVDATE1)
|
|---|
| 30 | .S WVACC=$P(Y,U) ;---> ACCESSION#
|
|---|
| 31 | .S WVPCD=$P(^WV(790.2,$P(Y,U,4),0),U,2) ;---> PROC TYPE
|
|---|
| 32 | .S WVSTAT=$$STATUS^WVUTL4 ;---> STATUS
|
|---|
| 33 | .S WVDIAG=$$DIAG^WVUTL4($P(Y,U,5)) ;---> RESULT/DIAG
|
|---|
| 34 | .S WVPROV=$P(Y,U,7) D ;---> PROVIDER
|
|---|
| 35 | ..I 'WVPROV S WVPROV="NOT ENTERED" Q
|
|---|
| 36 | ..S WVPROV=$P($$GET1^DIQ(200,WVPROV,.01,"E"),",")
|
|---|
| 37 | .;---> FOR PROCEDURES, SET 1ST PIECE AND 6TH SUBSCRIPT=1.
|
|---|
| 38 | .S X=1_U_U_U_WVDATE1_U_WVPCD_U_WVACC_U_WVDIAG
|
|---|
| 39 | .S X=X_U_WVPROV_U_WVSTAT_U_WVIEN
|
|---|
| 40 | .S ^TMP("WV",$J,1,9999999.9999-WVDATE,WVACC,1,WVIEN)=X Q
|
|---|
| 41 | ;
|
|---|
| 42 | ;**********************
|
|---|
| 43 | ;---> GET NOTIFICATIONS
|
|---|
| 44 | Q:'WVD
|
|---|
| 45 | S WVIEN=0
|
|---|
| 46 | F S WVIEN=$O(^WV(790.4,"B",WVDFN,WVIEN)) Q:'WVIEN D
|
|---|
| 47 | .S Y=^WV(790.4,WVIEN,0)
|
|---|
| 48 | .;---> QUIT IF NOT WITHIN DATE RANGE. WVDATE1 PRESERVES NOTIF DATE.
|
|---|
| 49 | .S (WVDATE,WVDATE1)=$P(Y,U,2)
|
|---|
| 50 | .;Q:WVDATE'>WVBEGDT1!(WVDATE>WVENDDT1) ;---> XDATE
|
|---|
| 51 | .S WVDATE1=$$SLDT2^WVUTL5(WVDATE1)
|
|---|
| 52 | .S WVACC=$P(Y,U,6) D ;---> ACCESSION#
|
|---|
| 53 | ..I WVACC="" S WVACC="NO ACC#" Q
|
|---|
| 54 | ..;---> IF THIS NOTIFICATION PERTAINS TO A PROCEDURE (I.E., IT
|
|---|
| 55 | ..;---> HAS AN ACCESSION#), RESET ITS DATE SO THAT IT WILL COLLATE
|
|---|
| 56 | ..;---> UNDER ITS PROCEDURE IN THE DISPLAY.
|
|---|
| 57 | ..S WVACC=$P(^WV(790.1,WVACC,0),U),WVDATE=$P(^(0),U,12)
|
|---|
| 58 | .S WVSTAT=$$STATUS^WVUTL4 ;---> STATUS
|
|---|
| 59 | .S WVTYPE=$P(Y,U,3) D ;---> TYPE
|
|---|
| 60 | ..I WVTYPE="" S WVTYPE="NOT ENTERED" Q
|
|---|
| 61 | ..S WVTYPE=$P(^WV(790.403,WVTYPE,0),U)
|
|---|
| 62 | .S WVPURP=$P(Y,U,4) D ;---> PURPOSE
|
|---|
| 63 | ..I WVPURP="" S WVPURP="NOT ENTERED" Q
|
|---|
| 64 | ..S WVPURP=$P(^WV(790.404,WVPURP,0),U)
|
|---|
| 65 | .S WVOUT=$P(Y,U,5) D ;---> OUTCOME
|
|---|
| 66 | ..I WVOUT="" S WVOUT="NOT ENTERED" Q
|
|---|
| 67 | ..S WVOUT=$P(^WV(790.405,WVOUT,0),U)
|
|---|
| 68 | .;---> FOR NOTIFICATIONS, SET 1ST PIECE AND 6TH SUBSCRIPT=2.
|
|---|
| 69 | .;S X=2_U_WVCHRT_U_WVNAME_U_WVDATE1_U_WVACC_U_WVTYPE_U_WVPURP
|
|---|
| 70 | .S X=2_U_U_U_WVDATE1_U_WVACC_U_WVTYPE_U_WVPURP
|
|---|
| 71 | .S X=X_U_WVOUT_U_WVSTAT_U_WVIEN
|
|---|
| 72 | .S ^TMP("WV",$J,1,9999999.9999-WVDATE,WVACC,2,WVIEN)=X Q
|
|---|
| 73 | ;
|
|---|
| 74 | ;**********************
|
|---|
| 75 | ;---> GET PAP REGIMENS
|
|---|
| 76 | S WVIEN=0
|
|---|
| 77 | F S WVIEN=$O(^WV(790.04,"C",WVDFN,WVIEN)) Q:'WVIEN D
|
|---|
| 78 | .;---> SET Y=THE ZERO NODE FOR THIS PAP REGIMEN LOG ENTRY.
|
|---|
| 79 | .S Y=^WV(790.04,WVIEN,0)
|
|---|
| 80 | .;---> PIECE 1=START DATE FOR THE PAP REGIMEN.
|
|---|
| 81 | .S (WVDATE,WVDATE1)=$P(Y,U) ;---> DATE
|
|---|
| 82 | .;---> QUIT IF NOT WITHIN DATE RANGE.
|
|---|
| 83 | .;Q:WVDATE'>WVBEGDT1!(WVDATE>WVENDDT1) ;---> XDATES
|
|---|
| 84 | .S WVDATE1=$$SLDT2^WVUTL5(WVDATE1)
|
|---|
| 85 | .S WVPAPRG1=$$PAPRG1^WVUTL1($P(Y,U,3)) ;---> PAP REGIMEN
|
|---|
| 86 | .;---> FOR PAP REGIMENS, SET 1ST PIECE AND 6TH SUBSCRIPT=3.
|
|---|
| 87 | .;S X=3_U_WVCHRT_U_WVNAME_U_WVDATE1_U_WVPAPRG1
|
|---|
| 88 | .S X=3_U_U_U_WVDATE1_U_WVPAPRG1
|
|---|
| 89 | .S ^TMP("WV",$J,1,9999999.9999-WVDATE,1,3,WVIEN)=X Q
|
|---|
| 90 | ;
|
|---|
| 91 | ;**********************
|
|---|
| 92 | ;---> GET PREGNANCIES
|
|---|
| 93 | S WVIEN=0
|
|---|
| 94 | F S WVIEN=$O(^WV(790.05,"C",WVDFN,WVIEN)) Q:'WVIEN D
|
|---|
| 95 | .;---> SET Y=THE ZERO NODE FOR THIS PREGNANCY LOG ENTRY.
|
|---|
| 96 | .S Y=^WV(790.05,WVIEN,0)
|
|---|
| 97 | .;---> PIECE 1=DATE PREGNANCY LOG ENTRY WAS MADE.
|
|---|
| 98 | .S (WVDATE,WVDATE1)=$P(Y,U) ;---> DATE
|
|---|
| 99 | .;---> QUIT IF NOT WITHIN DATE RANGE.
|
|---|
| 100 | .;Q:WVDATE'>WVBEGDT1!(WVDATE>WVENDDT1) ;---> XDATES
|
|---|
| 101 | .S WVDATE1=$$SLDT2^WVUTL5(WVDATE1)
|
|---|
| 102 | .S WVPSTAT=$S($P(Y,U,3):"PREGNANT",1:"NOT PREGNANT") ;---> PREG STATUS
|
|---|
| 103 | .S WVEDCL=$S(X:$$SLDT2^WVUTL5($P(Y,U,4)),1:"") ;---> EDC
|
|---|
| 104 | .;---> FOR PREGNANCIES, SET 1ST PIECE AND 6TH SUBSCRIPT=4.
|
|---|
| 105 | .;S X=4_U_WVCHRT_U_WVNAME_U_WVDATE1_U_WVPSTAT_U_WVEDCL
|
|---|
| 106 | .S X=4_U_U_U_WVDATE1_U_WVPSTAT_U_WVEDCL
|
|---|
| 107 | .S ^TMP("WV",$J,1,9999999.9999-WVDATE,1,4,WVIEN)=X Q
|
|---|
| 108 | Q
|
|---|
