BHSWH ;IHS/CIA/MGH - Health Summary for Women's health profile ;17-Mar-2006 10:36;MGH
;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
;===================================================================
;Rewrite of IHS health summary to use women's health in VA health summary format
;This routine writes out the health summary to the screen to be use din the EHR
;Taken from APCHS9B3
; IHS/TUCSON/LAB - women's health supplement ; [ 02/19/03 7:37 AM ]
;;2.0;IHS RPMS/PCC Health Summary;**3,5,8,9,10**;JUN 24, 1997
;
;
PROF ; Control Women's health profile retrieval and display;
N BWD
S BWD=0
K ^TMP("BHS",$J)
Q:$P($G(^DPT(DFN,0)),U,2)="M"
D EP^BHSWPROF(DFN,BWD)
Q:'$D(^TMP("BHS",$J))
D CKP^GMTSUP Q:$D(GMTSQIT)
D WHMAIN
Q
PROF2 ;Do detailed display of patient profile
N BWD
S BWD=1
K ^TMP("BHS",$J)
Q:$P($G(^DPT(DFN,0)),U,2)="M"
D EP^BHSWPROF(DFN,BWD)
Q:'$D(^TMP("BHS",$J))
D CKP^GMTSUP Q:$D(GMTSQIT)
D WHMAIN
Q
WHMAIN ; Main Display
N GMORDER,GMHR,GMDT,GMIFN,GMN0,GMW,X,GMTSDAT,HF,LEVEL,PHFC,COMMENT
N GMICL,GMTAB,GMTSLN,BWACCP,BWACC,Z
S (BWACCP,Z)=0
S GMORDER="" F S GMORDER=$O(^TMP("BHS",$J,GMORDER)) Q:GMORDER="" D Q:$D(GMTSQIT)
. I GMORDER=1 D HEADER
. I GMORDER=2 D RESULT
K ^TMP("BHS",$J)
Q
D CKP^GMTSUP Q:$D(GMTSQIT) W "* * * Patient Profile * * *",!
S GMHR="" F S GMHR=$O(^TMP("BHS",$J,GMORDER,GMHR)) Q:GMHR="" D Q:$D(GMTSQIT)
. D CKP^GMTSUP Q:$D(GMTSQIT)
. W $P($G(^TMP("BHS",$J,GMORDER,GMHR)),U,1)
. W ?50,$P($G(^TMP("BHS",$J,GMORDER,GMHR)),U,2),!
Q
RESULT ; Display Data from profile
I BWD=1 D DETAIL Q
D CKP^GMTSUP Q:$D(GMTSQIT)
W !,"DATE",?16,"PROCEDURE",?27,"RESULTS/DIAGNOSIS",?71,"STATUS"
D CKP^GMTSUP Q:$D(GMTSQIT)
W !,"--------",?16,"---------",?27,"----------------------------"
W ?71,"------"
S GMIFN="" F S GMIFN=$O(^TMP("BHS",$J,GMORDER,GMIFN)) Q:GMIFN="" D Q:$D(GMTSQIT)
.S GMN0=$G(^TMP("BHS",$J,GMORDER,GMIFN))
.D CKP^GMTSUP Q:$D(GMTSQIT)
.;---> QUIT IF NOT A PROCEDURE (PIECE 1'=1).
.Q:$P(GMN0,U)'=1
.W !,$P(GMN0,U,4) ;DATE OF PROCEDURE
.W ?17,$P(GMN0,U,5) ;PROCEDURE ABBREVIATION
.W ?27,$P(GMN0,U,7) ;RESULT
.W ?71,$P(GMN0,U,9) ;STATUS
.S BWACCP=$P(GMN0,U,6) ;STORE AS PREVIOUS ACCESS#
Q
DETAIL ;Display the detailed display
N I
S GMIFN="" F S GMIFN=$O(^TMP("BHS",$J,GMORDER,GMIFN)) Q:GMIFN="" D Q:$D(GMTSQIT)
.S GMN0=$G(^TMP("BHS",$J,GMORDER,GMIFN))
.D CKP^GMTSUP Q:$D(GMTSQIT)
.;Copied from BWPROF to display data from profile
.;---> IF PIECE 1=1 DISPLAY AS A PROCEDURE.
.I $P(GMN0,U)=1 D Q
..W !,"------------------------------< "
..W "PROCEDURE: ",$P(GMN0,U,5)," >" ;PROCEDURE ABBREVIATION
..F I=1:1:(6-$L($P(GMN0,U,5))) W "-"
..W "-----------------------------"
..W !,$P(GMN0,U,6) ;ACCESSION#
..;begin Y2K
..W ?16,$P(GMN0,U,4) ;DATE OF PROCEDURE ;IHS/CMI
..;end Y2K
..W ?27,"Res/Diag: ",$P(GMN0,U,7) ;RESULTS/DIAGNOSIS
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W !,?27,"Provider: ",$E($P(GMN0,U,8),1,14) ;PROVIDER
..W ?62,"Status: ",$P(GMN0,U,9) ;STATUS
..S BWACCP=$P(GMN0,U,6) ;STORE AS PREVIOUS ACCESS#
.;
.;---> **********************
.;---> DISPLAY NOTIFICATIONS
.;---> IF PIECE 1=2 DISPLAY AS A NOTIFICATION.
.I $P(GMN0,U)=2 D Q
..D CKP^GMTSUP Q:$D(GMTSQIT)
..S BWACC=$P(GMN0,U,5)
..I BWACC'=Z D
...;begin Y2K
...W ! W:BWACC["NO ACC#" "-----------------" W ?16 ;IHS/CMI/LAB 17 to 1
...;end Y2K
...W "-------------< NOTIFICATIONS >---------------------------------"
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W !
..W:BWACC'=BWACCP!(BWACC["NO ACC#") BWACC ;ACCESSION#
..;begin Y2K
..W ?16,$P(GMN0,U,4) ;DATE OF PROCEDURE;IHS/CMI
..;end Y2K
..W ?27,$E($P(GMN0,U,6)_": "_$P(GMN0,U,7),1,53) ;TYPE AND PURPOSE
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W !,?27,"Outcome: ",$E($P(GMN0,U,8),1,23) ;OUTCOME OF NOTIFICATION
..W ?62,"Status: ",$P(GMN0,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(GMN0,U)=3 D Q
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W !,"------------------------------< PAP REGIMEN CHANGE"
..W " >----------------------------"
..;begin Y2K
.. D CKP^GMTSUP Q:$D(GMTSQIT)
..W !?9,"Began:" ;IHS/CMI/LAB - 10 to 9 Y2000
..W ?16,$P(GMN0,U,4) ;DATE OF REGIMEN ENTRY ;IHS
..;end Y2K
..W ?27,"Regimen: ",$P(GMN0,U,5) ;PAP REGIMEN
.;
.;---> ********************** .;---> DISPLAY PREGNANCIES
.;---> IF PIECE 1=4 DISPLAY AS A PREGNANCY.
.I $P(GMN0,U)=4 D Q
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W !,"------------------------------< PREGNANCY STATUS"
..W " >------------------------------"
..;begin Y2K
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W !?6,"Entered:" ;IHS/CMI/LAB - 8 to 6 patch 5 Y2000
..W ?15,$P(GMN0,U,4) ;DATE OF PREGNANCY EDIT. ;I
..;end Y2K
..W ?27,$P(GMN0,U,5) ;PREGNANT/NOT
..W:$P(GMN0,U,6)]"" ?50,"EDC: ",$P(GMN0,U,6) ;EDC
Q
FORMAT ; Format Line
N DIWR,DIWL,DIWF,X
S DIWL=3,DIWR=80-(GMICL+GMTAB)
K ^UTILITY($J,"W")
S X=COMMENT D ^DIWP
Q
LINE ; Write Line
D CKP^GMTSUP Q:$D(GMTSQIT) W ?13,^UTILITY($J,"W",DIWL,GMTSLN,0),!
Q
BHSWH ;IHS/CIA/MGH - Health Summary for Women's health profile ;17-Mar-2006 10:36;MGH
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
+2 ;===================================================================
+3 ;Rewrite of IHS health summary to use women's health in VA health summary format
+4 ;This routine writes out the health summary to the screen to be use din the EHR
+5 ;Taken from APCHS9B3
+6 ; IHS/TUCSON/LAB - women's health supplement ; [ 02/19/03 7:37 AM ]
+7 ;;2.0;IHS RPMS/PCC Health Summary;**3,5,8,9,10**;JUN 24, 1997
+8 ;
+9 ;
PROF ; Control Women's health profile retrieval and display;
+1 NEW BWD
+2 SET BWD=0
+3 KILL ^TMP("BHS",$JOB)
+4 IF $PIECE($GET(^DPT(DFN,0)),U,2)="M"
QUIT
+5 DO EP^BHSWPROF(DFN,BWD)
+6 IF '$DATA(^TMP("BHS",$JOB))
QUIT
+7 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+8 DO WHMAIN
+9 QUIT
PROF2 ;Do detailed display of patient profile
+1 NEW BWD
+2 SET BWD=1
+3 KILL ^TMP("BHS",$JOB)
+4 IF $PIECE($GET(^DPT(DFN,0)),U,2)="M"
QUIT
+5 DO EP^BHSWPROF(DFN,BWD)
+6 IF '$DATA(^TMP("BHS",$JOB))
QUIT
+7 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+8 DO WHMAIN
+9 QUIT
WHMAIN ; Main Display
+1 NEW GMORDER,GMHR,GMDT,GMIFN,GMN0,GMW,X,GMTSDAT,HF,LEVEL,PHFC,COMMENT
+2 NEW GMICL,GMTAB,GMTSLN,BWACCP,BWACC,Z
+3 SET (BWACCP,Z)=0
+4 SET GMORDER=""
FOR
SET GMORDER=$ORDER(^TMP("BHS",$JOB,GMORDER))
IF GMORDER=""
QUIT
Begin DoDot:1
+5 IF GMORDER=1
DO HEADER
+6 IF GMORDER=2
DO RESULT
End DoDot:1
IF $DATA(GMTSQIT)
QUIT
+7 KILL ^TMP("BHS",$JOB)
+8 QUIT
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE "* * * Patient Profile * * *",!
+2 SET GMHR=""
FOR
SET GMHR=$ORDER(^TMP("BHS",$JOB,GMORDER,GMHR))
IF GMHR=""
QUIT
Begin DoDot:1
+3 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+4 WRITE $PIECE($GET(^TMP("BHS",$JOB,GMORDER,GMHR)),U,1)
+5 WRITE ?50,$PIECE($GET(^TMP("BHS",$JOB,GMORDER,GMHR)),U,2),!
End DoDot:1
IF $DATA(GMTSQIT)
QUIT
+6 QUIT
RESULT ; Display Data from profile
+1 IF BWD=1
DO DETAIL
QUIT
+2 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+3 WRITE !,"DATE",?16,"PROCEDURE",?27,"RESULTS/DIAGNOSIS",?71,"STATUS"
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+5 WRITE !,"--------",?16,"---------",?27,"----------------------------"
+6 WRITE ?71,"------"
+7 SET GMIFN=""
FOR
SET GMIFN=$ORDER(^TMP("BHS",$JOB,GMORDER,GMIFN))
IF GMIFN=""
QUIT
Begin DoDot:1
+8 SET GMN0=$GET(^TMP("BHS",$JOB,GMORDER,GMIFN))
+9 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+10 ;---> QUIT IF NOT A PROCEDURE (PIECE 1'=1).
+11 IF $PIECE(GMN0,U)'=1
QUIT
+12 ;DATE OF PROCEDURE
WRITE !,$PIECE(GMN0,U,4)
+13 ;PROCEDURE ABBREVIATION
WRITE ?17,$PIECE(GMN0,U,5)
+14 ;RESULT
WRITE ?27,$PIECE(GMN0,U,7)
+15 ;STATUS
WRITE ?71,$PIECE(GMN0,U,9)
+16 ;STORE AS PREVIOUS ACCESS#
SET BWACCP=$PIECE(GMN0,U,6)
End DoDot:1
IF $DATA(GMTSQIT)
QUIT
+17 QUIT
DETAIL ;Display the detailed display
+1 NEW I
+2 SET GMIFN=""
FOR
SET GMIFN=$ORDER(^TMP("BHS",$JOB,GMORDER,GMIFN))
IF GMIFN=""
QUIT
Begin DoDot:1
+3 SET GMN0=$GET(^TMP("BHS",$JOB,GMORDER,GMIFN))
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+5 ;Copied from BWPROF to display data from profile
+6 ;---> IF PIECE 1=1 DISPLAY AS A PROCEDURE.
+7 IF $PIECE(GMN0,U)=1
Begin DoDot:2
+8 WRITE !,"------------------------------< "
+9 ;PROCEDURE ABBREVIATION
WRITE "PROCEDURE: ",$PIECE(GMN0,U,5)," >"
+10 FOR I=1:1:(6-$LENGTH($PIECE(GMN0,U,5)))
WRITE "-"
+11 WRITE "-----------------------------"
+12 ;ACCESSION#
WRITE !,$PIECE(GMN0,U,6)
+13 ;begin Y2K
+14 ;DATE OF PROCEDURE ;IHS/CMI
WRITE ?16,$PIECE(GMN0,U,4)
+15 ;end Y2K
+16 ;RESULTS/DIAGNOSIS
WRITE ?27,"Res/Diag: ",$PIECE(GMN0,U,7)
+17 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+18 ;PROVIDER
WRITE !,?27,"Provider: ",$EXTRACT($PIECE(GMN0,U,8),1,14)
+19 ;STATUS
WRITE ?62,"Status: ",$PIECE(GMN0,U,9)
+20 ;STORE AS PREVIOUS ACCESS#
SET BWACCP=$PIECE(GMN0,U,6)
End DoDot:2
QUIT
+21 ;
+22 ;---> **********************
+23 ;---> DISPLAY NOTIFICATIONS
+24 ;---> IF PIECE 1=2 DISPLAY AS A NOTIFICATION.
+25 IF $PIECE(GMN0,U)=2
Begin DoDot:2
+26 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+27 SET BWACC=$PIECE(GMN0,U,5)
+28 IF BWACC'=Z
Begin DoDot:3
+29 ;begin Y2K
+30 ;IHS/CMI/LAB 17 to 1
WRITE !
IF BWACC["NO ACC#"
WRITE "-----------------"
WRITE ?16
+31 ;end Y2K
+32 WRITE "-------------< NOTIFICATIONS >---------------------------------"
End DoDot:3
+33 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+34 WRITE !
+35 ;ACCESSION#
IF BWACC'=BWACCP!(BWACC["NO ACC#")
WRITE BWACC
+36 ;begin Y2K
+37 ;DATE OF PROCEDURE;IHS/CMI
WRITE ?16,$PIECE(GMN0,U,4)
+38 ;end Y2K
+39 ;TYPE AND PURPOSE
WRITE ?27,$EXTRACT($PIECE(GMN0,U,6)_": "_$PIECE(GMN0,U,7),1,53)
+40 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+41 ;OUTCOME OF NOTIFICATION
WRITE !,?27,"Outcome: ",$EXTRACT($PIECE(GMN0,U,8),1,23)
+42 ;STATUS
WRITE ?62,"Status: ",$PIECE(GMN0,U,9)
+43 ;STORE AS PREVIOUS ACC#
SET (BWACCP,Z)=BWACC
+44 ;
+45 ;---> TWO VARIABLES (BWACCP & Z) USED ABOVE: "Z" SAYS "IF THIS NOTIF
+46 ;---> ACC# IS NOT THE SAME AS THE LAST ONE, DISPLAY --<NOT>-- BANNER.
+47 ;---> "BWACCP" SAYS "IF THIS NOTIF ACC# MATCHES THE LAST PROCEDURE'S
+48 ;---> ACC#, DON'T DISPLAY THE ACCESSION#."
+49 ;---> BOTH VARIABLES ARE RESET AFTER A FORMFEED, IN ORDER TO DISPLAY
+50 ;---> ON THE NEW PAGE.
End DoDot:2
QUIT
+51 ;
+52 ;---> **********************
+53 ;---> DISPLAY PAP REGIMENS
+54 ;---> IF PIECE 1=3 DISPLAY AS A PAP REGIMEN.
+55 IF $PIECE(GMN0,U)=3
Begin DoDot:2
+56 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+57 WRITE !,"------------------------------< PAP REGIMEN CHANGE"
+58 WRITE " >----------------------------"
+59 ;begin Y2K
+60 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+61 ;IHS/CMI/LAB - 10 to 9 Y2000
WRITE !?9,"Began:"
+62 ;DATE OF REGIMEN ENTRY ;IHS
WRITE ?16,$PIECE(GMN0,U,4)
+63 ;end Y2K
+64 ;PAP REGIMEN
WRITE ?27,"Regimen: ",$PIECE(GMN0,U,5)
End DoDot:2
QUIT
+65 ;
+66 ;---> ********************** .;---> DISPLAY PREGNANCIES
+67 ;---> IF PIECE 1=4 DISPLAY AS A PREGNANCY.
+68 IF $PIECE(GMN0,U)=4
Begin DoDot:2
+69 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+70 WRITE !,"------------------------------< PREGNANCY STATUS"
+71 WRITE " >------------------------------"
+72 ;begin Y2K
+73 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+74 ;IHS/CMI/LAB - 8 to 6 patch 5 Y2000
WRITE !?6,"Entered:"
+75 ;DATE OF PREGNANCY EDIT. ;I
WRITE ?15,$PIECE(GMN0,U,4)
+76 ;end Y2K
+77 ;PREGNANT/NOT
WRITE ?27,$PIECE(GMN0,U,5)
+78 ;EDC
IF $PIECE(GMN0,U,6)]""
WRITE ?50,"EDC: ",$PIECE(GMN0,U,6)
End DoDot:2
QUIT
End DoDot:1
IF $DATA(GMTSQIT)
QUIT
+79 QUIT
FORMAT ; Format Line
+1 NEW DIWR,DIWL,DIWF,X
+2 SET DIWL=3
SET DIWR=80-(GMICL+GMTAB)
+3 KILL ^UTILITY($JOB,"W")
+4 SET X=COMMENT
DO ^DIWP
+5 QUIT
LINE ; Write Line
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE ?13,^UTILITY($JOB,"W",DIWL,GMTSLN,0),!
+2 QUIT
