APCHS85 ; IHS/CMI/LAB - PART 8 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**2,7,10,11**;MAY 14, 2009;Build 58
;
;
REPHX ; ********** REPRODUCTIVE HISTORY * 9000017 **********
; <SETUP>
Q:$P(^DPT(APCHSPAT,0),U,2)'="F"
Q:'$D(^AUPNREP(APCHSPAT))
S APCHSN=^AUPNREP(APCHSPAT,0)
I $D(^DD(9000017,2101)) D NEWREP G REPHXX
; <DISPLAY>
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
S X=$P(APCHSN,U,2) I X]"" W X S APCHSP=3 D DTOBT W " "
S X=$P(APCHSN,U,4) S:X="" X="<not recorded>" S Y=X X:+X APCHSCVD W "LMP ",Y S APCHSP=5 D DTOBT W !
S X=$$VAL^XBDIQ1(9000017,APCHSPAT,2.01) W "LACTATION STATUS: ",X W:X]"" " (obtained "_$$DATE^APCHSMU($P($G(^AUPNREP(APCHSPAT,2)),U,2)) W !
;S X=$P(APCHSN,U,6) I X]"" S Y=$P(^DD(9000017,3,0),U,3),X=$P(Y,";",X+1) S APCHSM=$P(X,":",2) X APCHSCKP G:$D(APCHSQIT) REPHXX W "CONTRACEPTION: ",APCHSM S X=$P(APCHSN,U,7) X:+X "S Y=X X APCHSCVD W "", EFFECTIVE "",Y" S APCHSP=8 D DTOBT W !
;S X=$P(APCHSN,U,9) I X]"" X APCHSCKP G:$D(APCHSQIT) REPHXX D EDC
D LATER
REPHXX K APCHSN,APCHSM,APCHSN11
Q
;
NEWREP ;new reproductive factors dd
S APCHSN11=$G(^AUPNREP(APCHSPAT,0))
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
S X=$$RHX^AUPNREP(APCHSPAT) I X]"" W !,"Reproductive History: ",!?2,$P(X,";",1,4),";",!?3,$P(X,";",5,7),!?3,";",$P(X,";",8,99),! ;S APCHSP=30 D DTOBT11
X APCHSCKP Q:$D(APCHSQIT) ;X:'APCHSNPG APCHSBRK
S X=$P(APCHSN,U,4) I X]"" W "LMP: " S Y=X X APCHSCVD W Y S APCHSP=5 D DTOBT W !
S X=$$VAL^XBDIQ1(9000017,APCHSPAT,2.01) W "LACTATION STATUS: ",X W:X]"" " (obtained "_$$DATE^APCHSMU($P($G(^AUPNREP(APCHSPAT,2)),U,2)),")" W !
;S X=$P(APCHSN,U,6) I X]"" S Y=$P(^DD(9000017,3,0),U,3),X=$P(Y,";",X+1) S APCHSM=$P(X,":",2) X APCHSCKP G:$D(APCHSQIT) REPHXX W "CONTRACEPTION: ",APCHSM S X=$P(APCHSN,U,7) X:+X "S Y=X X APCHSCVD W "", EFFECTIVE "",Y" S APCHSP=8 D DTOBT W !
D LATER
Q:$D(APCHSQIT)
D EDC
Q
;
LATER ;
;TABLE ALL CONTRACEPTIVE HX BY DATE BEGUN, IF NO DATE BEGUN PUT AT TOP
;IF NOTHING IN 21 MULTIPLE THEN DISPLAY SINGLE VALUED FIELDSD
I '$O(^AUPNREP(APCHSPAT,2101,0)) D SINGLE Q
NEW APCHCM,APCHX,APCHC,APCHDB,APCHM
S APCHX=0 F S APCHX=$O(^AUPNREP(APCHSPAT,2101,APCHX)) Q:APCHX'=+APCHX D
.Q:$P($G(^AUPNREP(APCHSPAT,2101,APCHX,1)),U,1)]"" ;DELETED
.S APCHC=$P(^AUPNREP(APCHSPAT,2101,APCHX,0),U,1)
.Q:'APCHC
.S APCHDB=$P(^AUPNREP(APCHSPAT,2101,APCHX,0),U,2)
.S APCHDE=$P(^AUPNREP(APCHSPAT,2101,APCHX,0),U,3)
.Q:APCHDE]"" ;don't display history
.S APCHDB=+APCHDB
.S APCHCM((9999999-APCHDB),APCHX)=$$VAL^XBDIQ1(99999.11,APCHC,.01)_U_APCHDE_U_APCHDB
.Q
X APCHSCKP Q:$D(APCHSQIT) ;X:'APCHSNPG APCHSBRK
W !,"CURRENT CONTRACEPTION METHODS",!?3,"Contraceptive Method",?37,"Date Started",! ;,?50,"Date Ended"
S APCHDB="" F S APCHDB=$O(APCHCM(APCHDB)) Q:APCHDB=""!($D(APCHSQIT)) D
.S APCHX=0 F S APCHX=$O(APCHCM(APCHDB,APCHX)) Q:APCHX'=+APCHX!($D(APCHSQIT)) D
..X APCHSCKP Q:$D(APCHSQIT)
..W ?5,$P(APCHCM(APCHDB,APCHX),U,1)
..S Y=$P(APCHCM(APCHDB,APCHX),U,3) I Y X APCHSCVD W ?37,Y
..;S Y=$P(APCHCM(APCHDB,APCHX),U,2) I Y]"" X APCHSCVD W ?50,Y
..S Y=$P(^AUPNREP(APCHSPAT,2101,APCHX,0),U,4) W:Y]"" ?55,"(obtained "_$$DATE^APCHSMU(Y)_")" W !
..;W !
..I $P(^AUPNREP(APCHSPAT,2101,APCHX,0),U,6)]"" W ?10,$P(^AUPNREP(APCHSPAT,2101,APCHX,0),U,6),!
..I $P(^AUPNREP(APCHSPAT,2101,APCHX,0),U,5)]"" W ?5,"Reason Discontinued: "_$P(^AUPNREP(APCHSPAT,2101,APCHX,0),U,5),!
Q
SINGLE ;
S X=$P(APCHSN,U,6) I X]"" S Y=$P(^DD(9000017,3,0),U,3),X=$P(Y,";",X+1) S APCHSM=$P(X,":",2) X APCHSCKP G:$D(APCHSQIT) REPHXX W "CONTRACEPTION: ",APCHSM S X=$P(APCHSN,U,7) X:+X "S Y=X X APCHSCVD W "", EFFECTIVE "",Y" S APCHSP=8 D DTOBT W !
Q
DTOBT11 S Y=$P(APCHSN11,U,APCHSP) I Y]"" X APCHSCVD W " (obtained ",Y,")"
Q
DTOBT S Y=$P(APCHSN,U,APCHSP) I Y]"" X APCHSCVD W " (obtained ",Y,")"
Q
;
EDC ;S Y=$P(APCHSN,U,9)
;X APCHSCVD W "*** NOTE: EDC ",Y S APCHSP=11 D DTOBT
;I X<DT W " -- OUTDATED!"
;E S X=$P(APCHSN,U,10),APCHSM="UNKNOWN METHOD" S:X Y=$P(^DD(9000017,4.05,0),U,3),X=$P(Y,";",X+1),APCHSM=$P(X,":",2) W " BY ",APCHSM
;W !
I $G(APCHAEDD) D ALLEDD Q
NEW APCHDEDD,APCHDEDT,APCHDOBT,APCHBY
S APCHDEDD=$$VALI^XBDIQ1(9000017,APCHSPAT,1311)
I APCHDEDD]"" D Q
.;I APCHDEDD="L" S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1302),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1303)
.;I APCHDEDD="U" S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1305),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1306)
.;I APCHDEDD="C" S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1308),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1309)
.X APCHSCKP Q:$D(APCHSQIT)
.W "***NOTE: Definitive EDD: ",$$DATE^APCHSMU(APCHDEDD)," (obtained ",$$DATE^APCHSMU($P($P($G(^AUPNREP(APCHSPAT,13)),U,12),".")),")" ;
.I APCHDEDD<$$FMADD^XLFDT(DT,-14) W " -- OUTDATED!"
.X APCHSCKP Q:$D(APCHSQIT)
.W !
.I $P($G(^AUPNREP(APCHSPAT,15)),U,2)]"" W "Comment: ",$P(^AUPNREP(APCHSPAT,15),U,2)
.X APCHSCKP Q:$D(APCHSQIT)
.W !
;no definitive EDD so print latest of the 4 values
;
S APCHDOBT="",APCHBY="",APCHDEDT=""
I $$VAL^XBDIQ1(9000017,APCHSPAT,1302)]"" S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1302),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1303),APCHBY="LMP"
I $$VAL^XBDIQ1(9000017,APCHSPAT,1305)]"",$$VALI^XBDIQ1(9000017,APCHSPAT,1306)>APCHDOBT S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1305),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1306),APCHBY="ULTRASOUND"
I $$VAL^XBDIQ1(9000017,APCHSPAT,1308)]"",$$VALI^XBDIQ1(9000017,APCHSPAT,1309)>APCHDOBT S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1308),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1309),APCHBY="CLINICAL PARAMETERS"
I $$VAL^XBDIQ1(9000017,APCHSPAT,1314)]"",$$VALI^XBDIQ1(9000017,APCHSPAT,1315)>APCHDOBT S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1314),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1315),APCHBY="UNKNOWN METHOD"
I APCHDEDT]"" D
.X APCHSCKP Q:$D(APCHSQIT)
.W "***NOTE: EDD: ",$$DATE^APCHSMU(APCHDEDT)," (obtained ",$$DATE^APCHSMU(APCHDOBT),") BY ",APCHBY
.I APCHDEDT<$$FMADD^XLFDT(DT,-14) W " -- OUTDATED!"
.X APCHSCKP Q:$D(APCHSQIT)
.W !
.S F=$S(APCHBY="LMP":1401,APCHBY="ULTRASOUND":1402,APCHBY="CLINICAL PARAMETERS":1501,1:"1601")
.I $$VAL^XBDIQ1(9000017,APCHSPAT,F)]"" W "Comment: ",$$VAL^XBDIQ1(9000017,APCHSPAT,F)
.X APCHSCKP Q:$D(APCHSQIT)
.W !
Q
;
REPEDDHX ;EP - REPRODUCTIVE HISTORY - ALL EDDS
S APCHAEDD=1
D REPHX
K APCHAEDD
Q
;
ALLEDD ;
;print all EDDs with data
;1311, 1314, 1302, 1305, 1308
NEW APCHDEDD,APCHDEDT,APCHDOBT,APCHBY
S APCHDEDD=$$VALI^XBDIQ1(9000017,APCHSPAT,1311)
I APCHDEDD]"" D
.;I APCHDEDD="L" S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1302),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1303)
.;I APCHDEDD="U" S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1305),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1306)
.;I APCHDEDD="C" S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1308),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1309)
.X APCHSCKP Q:$D(APCHSQIT)
.W "***NOTE: Definitive EDD: ",$$DATE^APCHSMU(APCHDEDD)," (obtained ",$$DATE^APCHSMU($P($P($G(^AUPNREP(APCHSPAT,13)),U,12),".")),")" ; BY ",$S(APCHDEDD="L":"LMP",APCHDEDD="U":"ULTRASOUND",APCHDEDD="C":"CLINICAL PARAMETERS",1:"UNKNOWN METHOD")
.I APCHDEDD<$$FMADD^XLFDT(DT,-14) W " -- OUTDATED!"
.X APCHSCKP Q:$D(APCHSQIT)
.W !
.I $P($G(^AUPNREP(APCHSPAT,15)),U,2)]"" W "Comment: ",$P(^AUPNREP(APCHSPAT,15),U,2)
.X APCHSCKP Q:$D(APCHSQIT)
.W !
;NOW PRINT ALL OTHER EDD VALUES
I $$VAL^XBDIQ1(9000017,APCHSPAT,1302)]"" S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1302),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1303),APCHBY="LMP" D W
I $$VAL^XBDIQ1(9000017,APCHSPAT,1305)]"" S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1305),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1306),APCHBY="ULTRASOUND" D W
I $$VAL^XBDIQ1(9000017,APCHSPAT,1308)]"" S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1308),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1309),APCHBY="CLINICAL PARAMETERS" D W
I $$VAL^XBDIQ1(9000017,APCHSPAT,1314)]"" S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1314),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1315),APCHBY="UNKNOWN METHOD" D W
Q
W ;
I APCHDEDT]"" D
.X APCHSCKP Q:$D(APCHSQIT)
.W "***NOTE: EDD: ",$$DATE^APCHSMU(APCHDEDT)," (obtained ",$$DATE^APCHSMU(APCHDOBT),") BY ",APCHBY
.I APCHDEDT<$$FMADD^XLFDT(DT,-14) W " -- OUTDATED!"
.X APCHSCKP Q:$D(APCHSQIT)
.W !
.S F=$S(APCHBY="LMP":1401,APCHBY="ULTRASOUND":1402,APCHBY="CLINICAL PARAMETERS":1501,1:"1601")
.I $$VAL^XBDIQ1(9000017,APCHSPAT,F)]"" W "Comment: ",$$VAL^XBDIQ1(9000017,APCHSPAT,F)
.X APCHSCKP Q:$D(APCHSQIT)
.W !
.Q
Q
APCHS85 ; IHS/CMI/LAB - PART 8 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**2,7,10,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;
REPHX ; ********** REPRODUCTIVE HISTORY * 9000017 **********
+1 ; <SETUP>
+2 IF $PIECE(^DPT(APCHSPAT,0),U,2)'="F"
QUIT
+3 IF '$DATA(^AUPNREP(APCHSPAT))
QUIT
+4 SET APCHSN=^AUPNREP(APCHSPAT,0)
+5 IF $DATA(^DD(9000017,2101))
DO NEWREP
GOTO REPHXX
+6 ; <DISPLAY>
+7 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+8 SET X=$PIECE(APCHSN,U,2)
IF X]""
WRITE X
SET APCHSP=3
DO DTOBT
WRITE " "
+9 SET X=$PIECE(APCHSN,U,4)
IF X=""
SET X="<not recorded>"
SET Y=X
IF +X
XECUTE APCHSCVD
WRITE "LMP ",Y
SET APCHSP=5
DO DTOBT
WRITE !
+10 SET X=$$VAL^XBDIQ1(9000017,APCHSPAT,2.01)
WRITE "LACTATION STATUS: ",X
IF X]""
WRITE " (obtained "_$$DATE^APCHSMU($PIECE($GET(^AUPNREP(APCHSPAT,2)),U,2))
WRITE !
+11 ;S X=$P(APCHSN,U,6) I X]"" S Y=$P(^DD(9000017,3,0),U,3),X=$P(Y,";",X+1) S APCHSM=$P(X,":",2) X APCHSCKP G:$D(APCHSQIT) REPHXX W "CONTRACEPTION: ",APCHSM S X=$P(APCHSN,U,7) X:+X "S Y=X X APCHSCVD W "", EFFECTIVE "",Y" S APCHSP=8 D DTOBT W !
+12 ;S X=$P(APCHSN,U,9) I X]"" X APCHSCKP G:$D(APCHSQIT) REPHXX D EDC
+13 DO LATER
REPHXX KILL APCHSN,APCHSM,APCHSN11
+1 QUIT
+2 ;
NEWREP ;new reproductive factors dd
+1 SET APCHSN11=$GET(^AUPNREP(APCHSPAT,0))
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+3 ;S APCHSP=30 D DTOBT11
SET X=$$RHX^AUPNREP(APCHSPAT)
IF X]""
WRITE !,"Reproductive History: ",!?2,$PIECE(X,";",1,4),";",!?3,$PIECE(X,";",5,7),!?3,";",$PIECE(X,";",8,99),!
+4 ;X:'APCHSNPG APCHSBRK
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+5 SET X=$PIECE(APCHSN,U,4)
IF X]""
WRITE "LMP: "
SET Y=X
XECUTE APCHSCVD
WRITE Y
SET APCHSP=5
DO DTOBT
WRITE !
+6 SET X=$$VAL^XBDIQ1(9000017,APCHSPAT,2.01)
WRITE "LACTATION STATUS: ",X
IF X]""
WRITE " (obtained "_$$DATE^APCHSMU($PIECE($GET(^AUPNREP(APCHSPAT,2)),U,2)),")"
WRITE !
+7 ;S X=$P(APCHSN,U,6) I X]"" S Y=$P(^DD(9000017,3,0),U,3),X=$P(Y,";",X+1) S APCHSM=$P(X,":",2) X APCHSCKP G:$D(APCHSQIT) REPHXX W "CONTRACEPTION: ",APCHSM S X=$P(APCHSN,U,7) X:+X "S Y=X X APCHSCVD W "", EFFECTIVE "",Y" S APCHSP=8 D DTOBT W !
+8 DO LATER
+9 IF $DATA(APCHSQIT)
QUIT
+10 DO EDC
+11 QUIT
+12 ;
LATER ;
+1 ;TABLE ALL CONTRACEPTIVE HX BY DATE BEGUN, IF NO DATE BEGUN PUT AT TOP
+2 ;IF NOTHING IN 21 MULTIPLE THEN DISPLAY SINGLE VALUED FIELDSD
+3 IF '$ORDER(^AUPNREP(APCHSPAT,2101,0))
DO SINGLE
QUIT
+4 NEW APCHCM,APCHX,APCHC,APCHDB,APCHM
+5 SET APCHX=0
FOR
SET APCHX=$ORDER(^AUPNREP(APCHSPAT,2101,APCHX))
IF APCHX'=+APCHX
QUIT
Begin DoDot:1
+6 ;DELETED
IF $PIECE($GET(^AUPNREP(APCHSPAT,2101,APCHX,1)),U,1)]""
QUIT
+7 SET APCHC=$PIECE(^AUPNREP(APCHSPAT,2101,APCHX,0),U,1)
+8 IF 'APCHC
QUIT
+9 SET APCHDB=$PIECE(^AUPNREP(APCHSPAT,2101,APCHX,0),U,2)
+10 SET APCHDE=$PIECE(^AUPNREP(APCHSPAT,2101,APCHX,0),U,3)
+11 ;don't display history
IF APCHDE]""
QUIT
+12 SET APCHDB=+APCHDB
+13 SET APCHCM((9999999-APCHDB),APCHX)=$$VAL^XBDIQ1(99999.11,APCHC,.01)_U_APCHDE_U_APCHDB
+14 QUIT
End DoDot:1
+15 ;X:'APCHSNPG APCHSBRK
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+16 ;,?50,"Date Ended"
WRITE !,"CURRENT CONTRACEPTION METHODS",!?3,"Contraceptive Method",?37,"Date Started",!
+17 SET APCHDB=""
FOR
SET APCHDB=$ORDER(APCHCM(APCHDB))
IF APCHDB=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+18 SET APCHX=0
FOR
SET APCHX=$ORDER(APCHCM(APCHDB,APCHX))
IF APCHX'=+APCHX!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+19 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+20 WRITE ?5,$PIECE(APCHCM(APCHDB,APCHX),U,1)
+21 SET Y=$PIECE(APCHCM(APCHDB,APCHX),U,3)
IF Y
XECUTE APCHSCVD
WRITE ?37,Y
+22 ;S Y=$P(APCHCM(APCHDB,APCHX),U,2) I Y]"" X APCHSCVD W ?50,Y
+23 SET Y=$PIECE(^AUPNREP(APCHSPAT,2101,APCHX,0),U,4)
IF Y]""
WRITE ?55,"(obtained "_$$DATE^APCHSMU(Y)_")"
WRITE !
+24 ;W !
+25 IF $PIECE(^AUPNREP(APCHSPAT,2101,APCHX,0),U,6)]""
WRITE ?10,$PIECE(^AUPNREP(APCHSPAT,2101,APCHX,0),U,6),!
+26 IF $PIECE(^AUPNREP(APCHSPAT,2101,APCHX,0),U,5)]""
WRITE ?5,"Reason Discontinued: "_$PIECE(^AUPNREP(APCHSPAT,2101,APCHX,0),U,5),!
End DoDot:2
End DoDot:1
+27 QUIT
SINGLE ;
+1 SET X=$PIECE(APCHSN,U,6)
IF X]""
SET Y=$PIECE(^DD(9000017,3,0),U,3)
SET X=$PIECE(Y,";",X+1)
SET APCHSM=$PIECE(X,":",2)
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
GOTO REPHXX
WRITE "CONTRACEPTION: ",APCHSM
SET X=$PIECE(APCHSN,U,7)
IF +X
XECUTE "S Y=X X APCHSCVD W "", EFFECTIVE "",Y"
SET APCHSP=8
DO DTOBT
WRITE !
+2 QUIT
DTOBT11 SET Y=$PIECE(APCHSN11,U,APCHSP)
IF Y]""
XECUTE APCHSCVD
WRITE " (obtained ",Y,")"
+1 QUIT
DTOBT SET Y=$PIECE(APCHSN,U,APCHSP)
IF Y]""
XECUTE APCHSCVD
WRITE " (obtained ",Y,")"
+1 QUIT
+2 ;
EDC ;S Y=$P(APCHSN,U,9)
+1 ;X APCHSCVD W "*** NOTE: EDC ",Y S APCHSP=11 D DTOBT
+2 ;I X<DT W " -- OUTDATED!"
+3 ;E S X=$P(APCHSN,U,10),APCHSM="UNKNOWN METHOD" S:X Y=$P(^DD(9000017,4.05,0),U,3),X=$P(Y,";",X+1),APCHSM=$P(X,":",2) W " BY ",APCHSM
+4 ;W !
+5 IF $GET(APCHAEDD)
DO ALLEDD
QUIT
+6 NEW APCHDEDD,APCHDEDT,APCHDOBT,APCHBY
+7 SET APCHDEDD=$$VALI^XBDIQ1(9000017,APCHSPAT,1311)
+8 IF APCHDEDD]""
Begin DoDot:1
+9 ;I APCHDEDD="L" S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1302),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1303)
+10 ;I APCHDEDD="U" S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1305),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1306)
+11 ;I APCHDEDD="C" S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1308),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1309)
+12 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+13 ;
WRITE "***NOTE: Definitive EDD: ",$$DATE^APCHSMU(APCHDEDD)," (obtained ",$$DATE^APCHSMU($PIECE($PIECE($GET(^AUPNREP(APCHSPAT,13)),U,12),".")),")"
+14 IF APCHDEDD<$$FMADD^XLFDT(DT,-14)
WRITE " -- OUTDATED!"
+15 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+16 WRITE !
+17 IF $PIECE($GET(^AUPNREP(APCHSPAT,15)),U,2)]""
WRITE "Comment: ",$PIECE(^AUPNREP(APCHSPAT,15),U,2)
+18 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+19 WRITE !
End DoDot:1
QUIT
+20 ;no definitive EDD so print latest of the 4 values
+21 ;
+22 SET APCHDOBT=""
SET APCHBY=""
SET APCHDEDT=""
+23 IF $$VAL^XBDIQ1(9000017,APCHSPAT,1302)]""
SET APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1302)
SET APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1303)
SET APCHBY="LMP"
+24 IF $$VAL^XBDIQ1(9000017,APCHSPAT,1305)]""
IF $$VALI^XBDIQ1(9000017,APCHSPAT,1306)>APCHDOBT
SET APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1305)
SET APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1306)
SET APCHBY="ULTRASOUND"
+25 IF $$VAL^XBDIQ1(9000017,APCHSPAT,1308)]""
IF $$VALI^XBDIQ1(9000017,APCHSPAT,1309)>APCHDOBT
SET APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1308)
SET APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1309)
SET APCHBY="CLINICAL PARAMETERS"
+26 IF $$VAL^XBDIQ1(9000017,APCHSPAT,1314)]""
IF $$VALI^XBDIQ1(9000017,APCHSPAT,1315)>APCHDOBT
SET APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1314)
SET APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1315)
SET APCHBY="UNKNOWN METHOD"
+27 IF APCHDEDT]""
Begin DoDot:1
+28 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+29 WRITE "***NOTE: EDD: ",$$DATE^APCHSMU(APCHDEDT)," (obtained ",$$DATE^APCHSMU(APCHDOBT),") BY ",APCHBY
+30 IF APCHDEDT<$$FMADD^XLFDT(DT,-14)
WRITE " -- OUTDATED!"
+31 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+32 WRITE !
+33 SET F=$SELECT(APCHBY="LMP":1401,APCHBY="ULTRASOUND":1402,APCHBY="CLINICAL PARAMETERS":1501,1:"1601")
+34 IF $$VAL^XBDIQ1(9000017,APCHSPAT,F)]""
WRITE "Comment: ",$$VAL^XBDIQ1(9000017,APCHSPAT,F)
+35 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+36 WRITE !
End DoDot:1
+37 QUIT
+38 ;
REPEDDHX ;EP - REPRODUCTIVE HISTORY - ALL EDDS
+1 SET APCHAEDD=1
+2 DO REPHX
+3 KILL APCHAEDD
+4 QUIT
+5 ;
ALLEDD ;
+1 ;print all EDDs with data
+2 ;1311, 1314, 1302, 1305, 1308
+3 NEW APCHDEDD,APCHDEDT,APCHDOBT,APCHBY
+4 SET APCHDEDD=$$VALI^XBDIQ1(9000017,APCHSPAT,1311)
+5 IF APCHDEDD]""
Begin DoDot:1
+6 ;I APCHDEDD="L" S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1302),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1303)
+7 ;I APCHDEDD="U" S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1305),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1306)
+8 ;I APCHDEDD="C" S APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1308),APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1309)
+9 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+10 ; BY ",$S(APCHDEDD="L":"LMP",APCHDEDD="U":"ULTRASOUND",APCHDEDD="C":"CLINICAL PARAMETERS",1:"UNKNOWN METHOD")
WRITE "***NOTE: Definitive EDD: ",$$DATE^APCHSMU(APCHDEDD)," (obtained ",$$DATE^APCHSMU($PIECE($PIECE($GET(^AUPNREP(APCHSPAT,13)),U,12),".")),")"
+11 IF APCHDEDD<$$FMADD^XLFDT(DT,-14)
WRITE " -- OUTDATED!"
+12 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+13 WRITE !
+14 IF $PIECE($GET(^AUPNREP(APCHSPAT,15)),U,2)]""
WRITE "Comment: ",$PIECE(^AUPNREP(APCHSPAT,15),U,2)
+15 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+16 WRITE !
End DoDot:1
+17 ;NOW PRINT ALL OTHER EDD VALUES
+18 IF $$VAL^XBDIQ1(9000017,APCHSPAT,1302)]""
SET APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1302)
SET APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1303)
SET APCHBY="LMP"
DO W
+19 IF $$VAL^XBDIQ1(9000017,APCHSPAT,1305)]""
SET APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1305)
SET APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1306)
SET APCHBY="ULTRASOUND"
DO W
+20 IF $$VAL^XBDIQ1(9000017,APCHSPAT,1308)]""
SET APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1308)
SET APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1309)
SET APCHBY="CLINICAL PARAMETERS"
DO W
+21 IF $$VAL^XBDIQ1(9000017,APCHSPAT,1314)]""
SET APCHDEDT=$$VALI^XBDIQ1(9000017,APCHSPAT,1314)
SET APCHDOBT=$$VALI^XBDIQ1(9000017,APCHSPAT,1315)
SET APCHBY="UNKNOWN METHOD"
DO W
+22 QUIT
W ;
+1 IF APCHDEDT]""
Begin DoDot:1
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+3 WRITE "***NOTE: EDD: ",$$DATE^APCHSMU(APCHDEDT)," (obtained ",$$DATE^APCHSMU(APCHDOBT),") BY ",APCHBY
+4 IF APCHDEDT<$$FMADD^XLFDT(DT,-14)
WRITE " -- OUTDATED!"
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+6 WRITE !
+7 SET F=$SELECT(APCHBY="LMP":1401,APCHBY="ULTRASOUND":1402,APCHBY="CLINICAL PARAMETERS":1501,1:"1601")
+8 IF $$VAL^XBDIQ1(9000017,APCHSPAT,F)]""
WRITE "Comment: ",$$VAL^XBDIQ1(9000017,APCHSPAT,F)
+9 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+10 WRITE !
+11 QUIT
End DoDot:1
+12 QUIT
