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