- BWPROF3 ;IHS/ANMC/MWR - DISPLAY PATIENT PROFILE; [ 09/17/2001 7:54 AM ]
- ;;2.0;WOMEN'S HEALTH;**5,8**;MAY 16, 1996
- ;IHS/CMI/LAB - Y2K
- ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
- ;; DISPLAY CODE FOR PATIENT PROFILE. CALLED BY BWPROF1.
- ;
- NOMATCH ;EP
- ;---> QUIT IF NO RECORDS MATCH.
- I '$D(^TMP("BW",$J,1)) D Q
- .D HEADER2^BWUTL7
- .K BWPRMT,BWPRMT1,BWPRMTQ,DIR
- .W !!?5,"No records match the selected criteria.",!
- .D:BWCRT DIRZ^BWUTL3 W @IOF D ^%ZISC:'$G(BWEXT) S BWPOP=1 ;IHS/CMI/THL PATCH 8 DON'T CLOSE WHEN EXTERNAL CALL
- ;
- ;---> BWD=1:DETAILED DISPLAY, BWD=0:BRIEF DISPLAY.
- I BWD 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^BWUTL7
- F S N=$O(^TMP("BW",$J,2,N)) Q:'N!(BWPOP) D
- .I $Y+9>IOSL D:BWCRT DIRPRMT^BWUTL3 Q:BWPOP D
- ..S BWPAGE=BWPAGE+1
- ..D HEADER2^BWUTL7 S (BWACCP,Z)=0
- .S Y=^TMP("BW",$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
- ..F I=1:1:(6-$L($P(Y,U,5))) W "-"
- ..W "-----------------------------"
- ..W ! W:BWCRT $J(N,3),")" W ?BWTAB ;BROWSE SELECTION#
- ..W $P(Y,U,6) ;ACCESSION#
- ..;begin Y2K
- ..W ?16,$P(Y,U,4) ;DATE OF PROCEDURE ;IHS/CMI/LAB 17 to 16 Y2000
- ..;end Y2K
- ..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 BWACCP=$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 BWACC=$P(Y,U,5)
- ..I BWACC'=Z D
- ...;begin Y2K
- ...W ! W:BWACC["NO ACC#" "-----------------" W ?16 ;IHS/CMI/LAB 17 to 16 Y2000
- ...;end Y2K
- ...W "-------------< NOTIFICATIONS >---------------------------------"
- ..W ! W:BWCRT $J(N,3),")" W ?BWTAB ;BROWSE SELECTION#
- ..W:BWACC'=BWACCP!(BWACC["NO ACC#") BWACC ;ACCESSION#
- ..;begin Y2K
- ..W ?16,$P(Y,U,4) ;DATE OF PROCEDURE;IHS/CMI/LAB 17 to 16 Y2000
- ..;end Y2K
- ..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 (BWACCP,Z)=BWACC ;STORE AS PREVIOUS ACC#
- ..;
- ..;---> TWO VARIABLES (BWACCP & Z) USED ABOVE: "Z" SAYS "IF THIS NOTIF
- ..;---> ACC# IS NOT THE SAME AS THE LAST ONE, DISPLAY --<NOT>-- BANNER.
- ..;---> "BWACCP" 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 " >----------------------------"
- ..;begin Y2K
- ..W !?9,"Began:" ;IHS/CMI/LAB - 10 to 9 Y2000
- ..W ?16,$P(Y,U,4) ;DATE OF REGIMEN ENTRY ;IHS/CMI/LAB 17 to 16 Y2000
- ..;end Y2K
- ..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 " >------------------------------"
- ..;begin Y2K
- ..W !?6,"Entered:" ;IHS/CMI/LAB - 8 to 6 patch 5 Y2000
- ..W ?15,$P(Y,U,4) ;DATE OF PREGNANCY EDIT. ;IHS/CMI/LAB - 17 to 15 Y2000
- ..;end Y2K
- ..W ?27,$P(Y,U,5) ;PREGNANT/NOT
- ..W:$P(Y,U,6)]"" ?50,"EDC: ",$P(Y,U,6) ;EDC
- ;
- END ;EP
- W:'BWCRT @IOF
- ;---> IF A PROCEDURE HAS BEEN EDITED, SET N=N-5 AND START (GOTO)
- ;---> DISPLAY1 OVER AGAIN FROM 5 RECORDS PREVIOUS.
- I BWCRT&('$D(IO("S")))&('BWPOP) D DIRPRMT^BWUTL3 I N S N=N-1 G NOMATCH
- D ^%ZISC:'$G(BWEXT) ;IHS/CMI/THL PATCH 8 DON'T CLOSE WHEN EXTERNAL CALL
- K N,Z
- Q
- ;
- ;
- ;
- DISPLAY2 ;EP
- ;---> IF A PROCEDURE IS EDITED ON THE LAST PAGE, GOTO HERE
- ;---> FROM LINELABEL "END" BELOW.
- S BWSUBH="SUBHEAD^BWPROF1"
- D HEADER2^BWUTL7
- F S N=$O(^TMP("BW",$J,2,N)) Q:'N!(BWPOP) D
- .I $Y+9>IOSL D:BWCRT DIRPRMT^BWUTL3 Q:BWPOP D
- ..S BWPAGE=BWPAGE+1
- ..D HEADER2^BWUTL7 S (BWACCP,Z)=0
- .S Y=^TMP("BW",$J,2,N),M=N
- .;---> QUIT IF NOT A PROCEDURE (PIECE 1'=1).
- .Q:$P(Y,U)'=1
- .W ! W:BWCRT $J(N,3),")" W ?BWTAB ;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 BWACCP=$P(Y,U,6) ;STORE AS PREVIOUS ACCESS#
- END2 ;EP
- W:'BWCRT @IOF
- ;---> IF A PROCEDURE HAS BEEN EDITED, SET N=N-1 AND START (GOTO)
- ;---> DISPLAY2 OVER AGAIN FROM 5 RECORDS PREVIOUS.
- I BWCRT&('$D(IO("S")))&('BWPOP) D DIRPRMT^BWUTL3 I N S N=N-1 G NOMATCH
- D ^%ZISC:'$G(BWEXT) ;IHS/CMI/THL PATCH 8 DON'T CLOSE WHEN EXTERNAL CALL
- K N,Z
- Q
- BWPROF3 ;IHS/ANMC/MWR - DISPLAY PATIENT PROFILE; [ 09/17/2001 7:54 AM ]
- +1 ;;2.0;WOMEN'S HEALTH;**5,8**;MAY 16, 1996
- +2 ;IHS/CMI/LAB - Y2K
- +3 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
- +4 ;; DISPLAY CODE FOR PATIENT PROFILE. CALLED BY BWPROF1.
- +5 ;
- NOMATCH ;EP
- +1 ;---> QUIT IF NO RECORDS MATCH.
- +2 IF '$DATA(^TMP("BW",$JOB,1))
- Begin DoDot:1
- +3 DO HEADER2^BWUTL7
- +4 KILL BWPRMT,BWPRMT1,BWPRMTQ,DIR
- +5 WRITE !!?5,"No records match the selected criteria.",!
- +6 ;IHS/CMI/THL PATCH 8 DON'T CLOSE WHEN EXTERNAL CALL
- IF BWCRT
- DO DIRZ^BWUTL3
- WRITE @IOF
- IF '$GET(BWEXT)
- DO ^%ZISC
- SET BWPOP=1
- End DoDot:1
- QUIT
- +7 ;
- +8 ;---> BWD=1:DETAILED DISPLAY, BWD=0:BRIEF DISPLAY.
- +9 IF BWD
- DO DISPLAY1
- QUIT
- +10 DO DISPLAY2
- +11 QUIT
- +12 ;
- +13 ;
- DISPLAY1 ;EP
- +1 ;---> IF A PROCEDURE IS EDITED ON THE LAST PAGE, GOTO HERE
- +2 ;---> FROM LINELABEL "END" BELOW.
- +3 DO HEADER2^BWUTL7
- +4 FOR
- SET N=$ORDER(^TMP("BW",$JOB,2,N))
- IF 'N!(BWPOP)
- QUIT
- Begin DoDot:1
- +5 IF $Y+9>IOSL
- IF BWCRT
- DO DIRPRMT^BWUTL3
- IF BWPOP
- QUIT
- Begin DoDot:2
- +6 SET BWPAGE=BWPAGE+1
- +7 DO HEADER2^BWUTL7
- SET (BWACCP,Z)=0
- End DoDot:2
- +8 SET Y=^TMP("BW",$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 FOR I=1:1:(6-$LENGTH($PIECE(Y,U,5)))
- WRITE "-"
- +18 WRITE "-----------------------------"
- +19 ;BROWSE SELECTION#
- WRITE !
- IF BWCRT
- WRITE $JUSTIFY(N,3),")"
- WRITE ?BWTAB
- +20 ;ACCESSION#
- WRITE $PIECE(Y,U,6)
- +21 ;begin Y2K
- +22 ;DATE OF PROCEDURE ;IHS/CMI/LAB 17 to 16 Y2000
- WRITE ?16,$PIECE(Y,U,4)
- +23 ;end Y2K
- +24 ;RESULTS/DIAGNOSIS
- WRITE ?27,"Res/Diag: ",$PIECE(Y,U,7)
- +25 ;PROVIDER
- WRITE !?27,"Provider: ",$EXTRACT($PIECE(Y,U,8),1,14)
- +26 ;STATUS
- WRITE ?62,"Status: ",$PIECE(Y,U,9)
- +27 ;STORE AS PREVIOUS ACCESS#
- SET BWACCP=$PIECE(Y,U,6)
- End DoDot:2
- QUIT
- +28 ;
- +29 ;---> **********************
- +30 ;---> DISPLAY NOTIFICATIONS
- +31 ;---> IF PIECE 1=2 DISPLAY AS A NOTIFICATION.
- +32 IF $PIECE(Y,U)=2
- Begin DoDot:2
- +33 SET BWACC=$PIECE(Y,U,5)
- +34 IF BWACC'=Z
- Begin DoDot:3
- +35 ;begin Y2K
- +36 ;IHS/CMI/LAB 17 to 16 Y2000
- WRITE !
- IF BWACC["NO ACC#"
- WRITE "-----------------"
- WRITE ?16
- +37 ;end Y2K
- +38 WRITE "-------------< NOTIFICATIONS >---------------------------------"
- End DoDot:3
- +39 ;BROWSE SELECTION#
- WRITE !
- IF BWCRT
- WRITE $JUSTIFY(N,3),")"
- WRITE ?BWTAB
- +40 ;ACCESSION#
- IF BWACC'=BWACCP!(BWACC["NO ACC#")
- WRITE BWACC
- +41 ;begin Y2K
- +42 ;DATE OF PROCEDURE;IHS/CMI/LAB 17 to 16 Y2000
- WRITE ?16,$PIECE(Y,U,4)
- +43 ;end Y2K
- +44 ;TYPE AND PURPOSE
- WRITE ?27,$EXTRACT($PIECE(Y,U,6)_": "_$PIECE(Y,U,7),1,53)
- +45 ;OUTCOME OF NOTIFICATION
- WRITE !?27,"Outcome: ",$EXTRACT($PIECE(Y,U,8),1,23)
- +46 ;STATUS
- WRITE ?62,"Status: ",$PIECE(Y,U,9)
- +47 ;STORE AS PREVIOUS ACC#
- SET (BWACCP,Z)=BWACC
- +48 ;
- +49 ;---> TWO VARIABLES (BWACCP & Z) USED ABOVE: "Z" SAYS "IF THIS NOTIF
- +50 ;---> ACC# IS NOT THE SAME AS THE LAST ONE, DISPLAY --<NOT>-- BANNER.
- +51 ;---> "BWACCP" SAYS "IF THIS NOTIF ACC# MATCHES THE LAST PROCEDURE'S
- +52 ;---> ACC#, DON'T DISPLAY THE ACCESSION#."
- +53 ;---> BOTH VARIABLES ARE RESET AFTER A FORMFEED, IN ORDER TO DISPLAY
- +54 ;---> ON THE NEW PAGE.
- End DoDot:2
- QUIT
- +55 ;
- +56 ;---> **********************
- +57 ;---> DISPLAY PAP REGIMENS
- +58 ;---> IF PIECE 1=3 DISPLAY AS A PAP REGIMEN.
- +59 IF $PIECE(Y,U)=3
- Begin DoDot:2
- +60 WRITE !,"------------------------------< PAP REGIMEN CHANGE"
- +61 WRITE " >----------------------------"
- +62 ;begin Y2K
- +63 ;IHS/CMI/LAB - 10 to 9 Y2000
- WRITE !?9,"Began:"
- +64 ;DATE OF REGIMEN ENTRY ;IHS/CMI/LAB 17 to 16 Y2000
- WRITE ?16,$PIECE(Y,U,4)
- +65 ;end Y2K
- +66 ;PAP REGIMEN
- WRITE ?27,"Regimen: ",$PIECE(Y,U,5)
- End DoDot:2
- QUIT
- +67 ;
- +68 ;---> **********************
- +69 ;---> DISPLAY PREGNANCIES
- +70 ;---> IF PIECE 1=4 DISPLAY AS A PREGNANCY.
- +71 IF $PIECE(Y,U)=4
- Begin DoDot:2
- +72 WRITE !,"------------------------------< PREGNANCY STATUS"
- +73 WRITE " >------------------------------"
- +74 ;begin Y2K
- +75 ;IHS/CMI/LAB - 8 to 6 patch 5 Y2000
- WRITE !?6,"Entered:"
- +76 ;DATE OF PREGNANCY EDIT. ;IHS/CMI/LAB - 17 to 15 Y2000
- WRITE ?15,$PIECE(Y,U,4)
- +77 ;end Y2K
- +78 ;PREGNANT/NOT
- WRITE ?27,$PIECE(Y,U,5)
- +79 ;EDC
- IF $PIECE(Y,U,6)]""
- WRITE ?50,"EDC: ",$PIECE(Y,U,6)
- End DoDot:2
- QUIT
- End DoDot:1
- +80 ;
- END ;EP
- +1 IF 'BWCRT
- WRITE @IOF
- +2 ;---> IF A PROCEDURE HAS BEEN EDITED, SET N=N-5 AND START (GOTO)
- +3 ;---> DISPLAY1 OVER AGAIN FROM 5 RECORDS PREVIOUS.
- +4 IF BWCRT&('$DATA(IO("S")))&('BWPOP)
- DO DIRPRMT^BWUTL3
- IF N
- SET N=N-1
- GOTO NOMATCH
- +5 ;IHS/CMI/THL PATCH 8 DON'T CLOSE WHEN EXTERNAL CALL
- IF '$GET(BWEXT)
- DO ^%ZISC
- +6 KILL N,Z
- +7 QUIT
- +8 ;
- +9 ;
- +10 ;
- DISPLAY2 ;EP
- +1 ;---> IF A PROCEDURE IS EDITED ON THE LAST PAGE, GOTO HERE
- +2 ;---> FROM LINELABEL "END" BELOW.
- +3 SET BWSUBH="SUBHEAD^BWPROF1"
- +4 DO HEADER2^BWUTL7
- +5 FOR
- SET N=$ORDER(^TMP("BW",$JOB,2,N))
- IF 'N!(BWPOP)
- QUIT
- Begin DoDot:1
- +6 IF $Y+9>IOSL
- IF BWCRT
- DO DIRPRMT^BWUTL3
- IF BWPOP
- QUIT
- Begin DoDot:2
- +7 SET BWPAGE=BWPAGE+1
- +8 DO HEADER2^BWUTL7
- SET (BWACCP,Z)=0
- End DoDot:2
- +9 SET Y=^TMP("BW",$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 BWCRT
- WRITE $JUSTIFY(N,3),")"
- WRITE ?BWTAB
- +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 BWACCP=$PIECE(Y,U,6)
- End DoDot:1
- END2 ;EP
- +1 IF 'BWCRT
- WRITE @IOF
- +2 ;---> IF A PROCEDURE HAS BEEN EDITED, SET N=N-1 AND START (GOTO)
- +3 ;---> DISPLAY2 OVER AGAIN FROM 5 RECORDS PREVIOUS.
- +4 IF BWCRT&('$DATA(IO("S")))&('BWPOP)
- DO DIRPRMT^BWUTL3
- IF N
- SET N=N-1
- GOTO NOMATCH
- +5 ;IHS/CMI/THL PATCH 8 DON'T CLOSE WHEN EXTERNAL CALL
- IF '$GET(BWEXT)
- DO ^%ZISC
- +6 KILL N,Z
- +7 QUIT
