WVPROF3 ;HCIOFO/FT,JR - DISPLAY PATIENT PROFILE;05/25/2017 15:15
;;1.0;WOMEN'S HEALTH;**24**;Sep 30, 1998;Build 582
;;IHS/ANMC/MWR
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; DISPLAY CODE FOR PATIENT PROFILE. CALLED BY WVPROF1.
;
NOMATCH ;EP
;---> QUIT IF NO RECORDS MATCH.
N M
I '$D(^TMP("WV",$J,1)) D Q
.D HEADER2^WVUTL7
.K WVPRMT,WVPRMT1,WVPRMTQ,DIR
.W !!?5,"No records match the selected criteria.",!
.I WVCRT&('$D(IO("S"))) D DIRZ^WVUTL3 W @IOF
.D ^%ZISC S WVPOP=1
;
;---> WVD=1:DETAILED DISPLAY, WVD=0:BRIEF DISPLAY.
I WVD D DISPLAY1 Q
D DISPLAY2
Q
;
;
DISPLAY1 ;EP
;---> IF A PROCEDURE IS EDITED ON THE LAST PAGE, GOTO HERE
;---> FROM LINELABEL "END" BELOW.
D HEADER2^WVUTL7
F S N=$O(^TMP("WV",$J,2,N)) Q:'N!(WVPOP) D
.I $Y+5>IOSL D:WVCRT DIRZ^WVUTL3 Q:WVPOP D
..S WVPAGE=WVPAGE+1
..D HEADER2^WVUTL7 S (WVACCP,Z)=0
.S Y=^TMP("WV",$J,2,N),M=N
.W !
.;
.;---> **********************
.;---> DISPLAY PROCEDURES
.;---> IF PIECE 1=1 DISPLAY AS A PROCEDURE.
.I $P(Y,U)=1 D Q
..W !,"------------------------------< "
..W "PROCEDURE: ",$P(Y,U,5)," >" ;PROCEDURE ABBREVIATION
..W $$REPEAT^XLFSTR("-",(6-$L($P(Y,U,5))))
..;F I=1:1:(6-$L($P(Y,U,5))) W "-"
..W "-----------------------------"
..W ! W:WVCRT $J(N,3),")" W ?WVTAB ;BROWSE SELECTION#
..W $P(Y,U,6) ;ACCESSION#
..W ?17,$P(Y,U,4) ;DATE OF PROCEDURE
..W ?27,"Res/Diag: ",$P(Y,U,7) ;RESULTS/DIAGNOSIS
..W !?27,"Provider: ",$E($P(Y,U,8),1,14) ;PROVIDER
..W ?62,"Status: ",$P(Y,U,9) ;STATUS
..S WVACCP=$P(Y,U,6) ;STORE AS PREVIOUS ACCESS#
.;
.;---> **********************
.;---> DISPLAY NOTIFICATIONS
.;---> IF PIECE 1=2 DISPLAY AS A NOTIFICATION.
.I $P(Y,U)=2 D Q
..S WVACC=$P(Y,U,5)
..I WVACC'=Z D
...W ! W:WVACC["NO ACC#" "-----------------" W ?17
...W "-------------< NOTIFICATIONS >---------------------------------"
..W ! W:WVCRT $J(N,3),")" W ?WVTAB ;BROWSE SELECTION#
..W:WVACC'=WVACCP!(WVACC["NO ACC#") WVACC ;ACCESSION#
..W ?17,$P(Y,U,4) ;DATE OF PROCEDURE
..W ?27,$E($P(Y,U,6)_": "_$P(Y,U,7),1,53) ;TYPE AND PURPOSE
..W !?27,"Outcome: ",$E($P(Y,U,8),1,23) ;OUTCOME OF NOTIFICATION
..W ?62,"Status: ",$P(Y,U,9) ;STATUS
..S (WVACCP,Z)=WVACC ;STORE AS PREVIOUS ACC#
..;
..;---> TWO VARIABLES (WVACCP & Z) USED ABOVE: "Z" SAYS "IF THIS NOTIF
..;---> ACC# IS NOT THE SAME AS THE LAST ONE, DISPLAY --<NOT>-- BANNER.
..;---> "WVACCP" SAYS "IF THIS NOTIF ACC# MATCHES THE LAST PROCEDURE'S
..;---> ACC#, DON'T DISPLAY THE ACCESSION#."
..;---> BOTH VARIABLES ARE RESET AFTER A FORMFEED, IN ORDER TO DISPLAY
..;---> ON THE NEW PAGE.
.;
.;---> **********************
.;---> DISPLAY PAP REGIMENS
.;---> IF PIECE 1=3 DISPLAY AS A PAP REGIMEN.
.I $P(Y,U)=3 D Q
..W !,"------------------------------< PAP REGIMEN CHANGE"
..W " >----------------------------"
..W !?10,"Began:"
..W ?17,$P(Y,U,4) ;DATE OF REGIMEN ENTRY
..W ?27,"Regimen: ",$P(Y,U,5) ;PAP REGIMEN
.;
.;---> **********************
.;---> DISPLAY PREGNANCIES
.;---> IF PIECE 1=4 DISPLAY AS A PREGNANCY.
.I $P(Y,U)=4 D Q
..W !,"------------------------------< PREGNANCY STATUS"
..W " >------------------------------"
..W !?8,"Entered:"
..W ?17,$P(Y,U,4) ;DATE OF PREGNANCY EDIT.
..W ?27,$P(Y,U,5) ;PREGNANT/NOT
..W:$P(Y,U,6)]"" ?50,"EDD: ",$P(Y,U,6) ;EDD
;
END ;EP
;---> IF A PROCEDURE HAS BEEN EDITED, SET N=N-5 AND START (GOTO)
;---> DISPLAY1 OVER AGAIN FROM 5 RECORDS PREVIOUS.
I WVCRT&('$D(IO("S")))&('WVPOP) D DIRZ^WVUTL3 I N S N=N-1 G NOMATCH
D ^%ZISC
K N,Z
Q
;
;
;
DISPLAY2 ;EP
;---> IF A PROCEDURE IS EDITED ON THE LAST PAGE, GOTO HERE
;---> FROM LINELABEL "END" BELOW.
S WVSUBH="SUBHEAD^WVPROF1"
D HEADER2^WVUTL7
F S N=$O(^TMP("WV",$J,2,N)) Q:'N!(WVPOP) D
.I $Y+5>IOSL D:WVCRT DIRZ^WVUTL3 Q:WVPOP D
..S WVPAGE=WVPAGE+1
..D HEADER2^WVUTL7 S (WVACCP,Z)=0
.S Y=^TMP("WV",$J,2,N),M=N
.;---> QUIT IF NOT A PROCEDURE (PIECE 1'=1).
.Q:$P(Y,U)'=1
.W ! W:WVCRT $J(N,3),")" W ?WVTAB ;BROWSE SELECTION#
.W $P(Y,U,4) ;DATE OF PROCEDURE
.W ?17,$P(Y,U,5) ;PROCEDURE ABBREVIATION
.W ?27,$P(Y,U,7) ;RESULT
.W ?71,$P(Y,U,9) ;STATUS
.S WVACCP=$P(Y,U,6) ;STORE AS PREVIOUS ACCESS#
END2 ;EP
;---> IF A PROCEDURE HAS BEEN EDITED, SET N=N-1 AND START (GOTO)
;---> DISPLAY2 OVER AGAIN FROM 5 RECORDS PREVIOUS.
I WVCRT&('$D(IO("S")))&('WVPOP) D DIRZ^WVUTL3 I N S N=N-1 G NOMATCH
D ^%ZISC
K N,Z
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVPROF3 4926 printed Sep 23, 2025@20:23:47 Page 2
WVPROF3 ;HCIOFO/FT,JR - DISPLAY PATIENT PROFILE;05/25/2017 15:15
+1 ;;1.0;WOMEN'S HEALTH;**24**;Sep 30, 1998;Build 582
+2 ;;IHS/ANMC/MWR
+3 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+4 ;; DISPLAY CODE FOR PATIENT PROFILE. CALLED BY WVPROF1.
+5 ;
NOMATCH ;EP
+1 ;---> QUIT IF NO RECORDS MATCH.
+2 NEW M
+3 IF '$DATA(^TMP("WV",$JOB,1))
Begin DoDot:1
+4 DO HEADER2^WVUTL7
+5 KILL WVPRMT,WVPRMT1,WVPRMTQ,DIR
+6 WRITE !!?5,"No records match the selected criteria.",!
+7 IF WVCRT&('$DATA(IO("S")))
DO DIRZ^WVUTL3
WRITE @IOF
+8 DO ^%ZISC
SET WVPOP=1
End DoDot:1
QUIT
+9 ;
+10 ;---> WVD=1:DETAILED DISPLAY, WVD=0:BRIEF DISPLAY.
+11 IF WVD
DO DISPLAY1
QUIT
+12 DO DISPLAY2
+13 QUIT
+14 ;
+15 ;
DISPLAY1 ;EP
+1 ;---> IF A PROCEDURE IS EDITED ON THE LAST PAGE, GOTO HERE
+2 ;---> FROM LINELABEL "END" BELOW.
+3 DO HEADER2^WVUTL7
+4 FOR
SET N=$ORDER(^TMP("WV",$JOB,2,N))
if 'N!(WVPOP)
QUIT
Begin DoDot:1
+5 IF $Y+5>IOSL
if WVCRT
DO DIRZ^WVUTL3
if WVPOP
QUIT
Begin DoDot:2
+6 SET WVPAGE=WVPAGE+1
+7 DO HEADER2^WVUTL7
SET (WVACCP,Z)=0
End DoDot:2
+8 SET Y=^TMP("WV",$JOB,2,N)
SET M=N
+9 WRITE !
+10 ;
+11 ;---> **********************
+12 ;---> DISPLAY PROCEDURES
+13 ;---> IF PIECE 1=1 DISPLAY AS A PROCEDURE.
+14 IF $PIECE(Y,U)=1
Begin DoDot:2
+15 WRITE !,"------------------------------< "
+16 ;PROCEDURE ABBREVIATION
WRITE "PROCEDURE: ",$PIECE(Y,U,5)," >"
+17 WRITE $$REPEAT^XLFSTR("-",(6-$LENGTH($PIECE(Y,U,5))))
+18 ;F I=1:1:(6-$L($P(Y,U,5))) W "-"
+19 WRITE "-----------------------------"
+20 ;BROWSE SELECTION#
WRITE !
if WVCRT
WRITE $JUSTIFY(N,3),")"
WRITE ?WVTAB
+21 ;ACCESSION#
WRITE $PIECE(Y,U,6)
+22 ;DATE OF PROCEDURE
WRITE ?17,$PIECE(Y,U,4)
+23 ;RESULTS/DIAGNOSIS
WRITE ?27,"Res/Diag: ",$PIECE(Y,U,7)
+24 ;PROVIDER
WRITE !?27,"Provider: ",$EXTRACT($PIECE(Y,U,8),1,14)
+25 ;STATUS
WRITE ?62,"Status: ",$PIECE(Y,U,9)
+26 ;STORE AS PREVIOUS ACCESS#
SET WVACCP=$PIECE(Y,U,6)
End DoDot:2
QUIT
+27 ;
+28 ;---> **********************
+29 ;---> DISPLAY NOTIFICATIONS
+30 ;---> IF PIECE 1=2 DISPLAY AS A NOTIFICATION.
+31 IF $PIECE(Y,U)=2
Begin DoDot:2
+32 SET WVACC=$PIECE(Y,U,5)
+33 IF WVACC'=Z
Begin DoDot:3
+34 WRITE !
if WVACC["NO ACC#"
WRITE "-----------------"
WRITE ?17
+35 WRITE "-------------< NOTIFICATIONS >---------------------------------"
End DoDot:3
+36 ;BROWSE SELECTION#
WRITE !
if WVCRT
WRITE $JUSTIFY(N,3),")"
WRITE ?WVTAB
+37 ;ACCESSION#
if WVACC'=WVACCP!(WVACC["NO ACC#")
WRITE WVACC
+38 ;DATE OF PROCEDURE
WRITE ?17,$PIECE(Y,U,4)
+39 ;TYPE AND PURPOSE
WRITE ?27,$EXTRACT($PIECE(Y,U,6)_": "_$PIECE(Y,U,7),1,53)
+40 ;OUTCOME OF NOTIFICATION
WRITE !?27,"Outcome: ",$EXTRACT($PIECE(Y,U,8),1,23)
+41 ;STATUS
WRITE ?62,"Status: ",$PIECE(Y,U,9)
+42 ;STORE AS PREVIOUS ACC#
SET (WVACCP,Z)=WVACC
+43 ;
+44 ;---> TWO VARIABLES (WVACCP & Z) USED ABOVE: "Z" SAYS "IF THIS NOTIF
+45 ;---> ACC# IS NOT THE SAME AS THE LAST ONE, DISPLAY --<NOT>-- BANNER.
+46 ;---> "WVACCP" SAYS "IF THIS NOTIF ACC# MATCHES THE LAST PROCEDURE'S
+47 ;---> ACC#, DON'T DISPLAY THE ACCESSION#."
+48 ;---> BOTH VARIABLES ARE RESET AFTER A FORMFEED, IN ORDER TO DISPLAY
+49 ;---> ON THE NEW PAGE.
End DoDot:2
QUIT
+50 ;
+51 ;---> **********************
+52 ;---> DISPLAY PAP REGIMENS
+53 ;---> IF PIECE 1=3 DISPLAY AS A PAP REGIMEN.
+54 IF $PIECE(Y,U)=3
Begin DoDot:2
+55 WRITE !,"------------------------------< PAP REGIMEN CHANGE"
+56 WRITE " >----------------------------"
+57 WRITE !?10,"Began:"
+58 ;DATE OF REGIMEN ENTRY
WRITE ?17,$PIECE(Y,U,4)
+59 ;PAP REGIMEN
WRITE ?27,"Regimen: ",$PIECE(Y,U,5)
End DoDot:2
QUIT
+60 ;
+61 ;---> **********************
+62 ;---> DISPLAY PREGNANCIES
+63 ;---> IF PIECE 1=4 DISPLAY AS A PREGNANCY.
+64 IF $PIECE(Y,U)=4
Begin DoDot:2
+65 WRITE !,"------------------------------< PREGNANCY STATUS"
+66 WRITE " >------------------------------"
+67 WRITE !?8,"Entered:"
+68 ;DATE OF PREGNANCY EDIT.
WRITE ?17,$PIECE(Y,U,4)
+69 ;PREGNANT/NOT
WRITE ?27,$PIECE(Y,U,5)
+70 ;EDD
if $PIECE(Y,U,6)]""
WRITE ?50,"EDD: ",$PIECE(Y,U,6)
End DoDot:2
QUIT
End DoDot:1
+71 ;
END ;EP
+1 ;---> IF A PROCEDURE HAS BEEN EDITED, SET N=N-5 AND START (GOTO)
+2 ;---> DISPLAY1 OVER AGAIN FROM 5 RECORDS PREVIOUS.
+3 IF WVCRT&('$DATA(IO("S")))&('WVPOP)
DO DIRZ^WVUTL3
IF N
SET N=N-1
GOTO NOMATCH
+4 DO ^%ZISC
+5 KILL N,Z
+6 QUIT
+7 ;
+8 ;
+9 ;
DISPLAY2 ;EP
+1 ;---> IF A PROCEDURE IS EDITED ON THE LAST PAGE, GOTO HERE
+2 ;---> FROM LINELABEL "END" BELOW.
+3 SET WVSUBH="SUBHEAD^WVPROF1"
+4 DO HEADER2^WVUTL7
+5 FOR
SET N=$ORDER(^TMP("WV",$JOB,2,N))
if 'N!(WVPOP)
QUIT
Begin DoDot:1
+6 IF $Y+5>IOSL
if WVCRT
DO DIRZ^WVUTL3
if WVPOP
QUIT
Begin DoDot:2
+7 SET WVPAGE=WVPAGE+1
+8 DO HEADER2^WVUTL7
SET (WVACCP,Z)=0
End DoDot:2
+9 SET Y=^TMP("WV",$JOB,2,N)
SET M=N
+10 ;---> QUIT IF NOT A PROCEDURE (PIECE 1'=1).
+11 if $PIECE(Y,U)'=1
QUIT
+12 ;BROWSE SELECTION#
WRITE !
if WVCRT
WRITE $JUSTIFY(N,3),")"
WRITE ?WVTAB
+13 ;DATE OF PROCEDURE
WRITE $PIECE(Y,U,4)
+14 ;PROCEDURE ABBREVIATION
WRITE ?17,$PIECE(Y,U,5)
+15 ;RESULT
WRITE ?27,$PIECE(Y,U,7)
+16 ;STATUS
WRITE ?71,$PIECE(Y,U,9)
+17 ;STORE AS PREVIOUS ACCESS#
SET WVACCP=$PIECE(Y,U,6)
End DoDot:1
END2 ;EP
+1 ;---> IF A PROCEDURE HAS BEEN EDITED, SET N=N-1 AND START (GOTO)
+2 ;---> DISPLAY2 OVER AGAIN FROM 5 RECORDS PREVIOUS.
+3 IF WVCRT&('$DATA(IO("S")))&('WVPOP)
DO DIRZ^WVUTL3
IF N
SET N=N-1
GOTO NOMATCH
+4 DO ^%ZISC
+5 KILL N,Z
+6 QUIT
