Routine: APCHS85

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

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

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),!

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 !

DTOBT11 S Y=$P(APCHSN11,U,APCHSP) I Y]"" X APCHSCVD W " (obtained ",Y,")"

DTOBT S Y=$P(APCHSN,U,APCHSP) I Y]"" X APCHSCVD W " (obtained ",Y,")"

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 !

REPEDDHX ;EP - REPRODUCTIVE HISTORY - ALL EDDS

 S APCHAEDD=1

 D REPHX

 K APCHAEDD

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

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

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

APCHS85.m