APCDFH1 ; IHS/CMI/LAB - LIST MANAGER API'S FOR FAMILY HISTORY AND API FOR REP FACTORS 19 Jun 2008 2:14 PM ;
;;2.0;IHS PCC SUITE;**2,7,10,11,17**;MAY 14, 2009;Build 18
;
;
FM ;EP - called from d/e input template APCD FP (FP)
S APCDREPI=DA
D EN^XBNEW("FM1^APCDFH","APCDREPI;APCDDATE")
K Y
Q
FM1 ;EP - called from XBNEW call
S APCDC=0 K APCDCM
W !!,"Contraceptive Methods currently recorded:"
I '$O(^AUPNREP(APCDREPI,2101,0)) S APCDC=0 W " None recorded" G FM12
D EN^DDIOL("Contraceptive Method","","!?3"),EN^DDIOL("Start Date","","?43"),EN^DDIOL("End Date","","?63")
D EN^DDIOL($$REPEAT^XLFSTR("-",75),"","!?3")
K APCDCM S X=0,APCDC=0 F S X=$O(^AUPNREP(APCDREPI,2101,X)) Q:X'=+X D
.Q:$P($G(^AUPNREP(APCDREPI,2101,X,1)),U,1)]"" ;DELETED
.S APCDC=APCDC+1,APCDCM(APCDC)=X
.W !?2,APCDC,") ",$P(^AUTTCM($P(^AUPNREP(APCDREPI,2101,X,0),U),0),U),?43,$$FMTE^XLFDT($P(^AUPNREP(APCDREPI,2101,X,0),U,2)),?63,$$FMTE^XLFDT($P(^AUPNREP(APCDREPI,2101,X,0),U,3))
.I $P(^AUPNREP(APCDREPI,2101,X,0),U,6)]"" W !?4,"Comment: ",$P(^AUPNREP(APCDREPI,2101,X,0),U,6)
.I $P(^AUPNREP(APCDREPI,2101,X,0),U,7)]"" W !?4,"Reason Discontinued: ",$P(^AUPNREP(APCDREPI,2101,X,0),U,7)
FM12 ;
D EN^DDIOL("","","!!")
K DIR
S DIR(0)="S^A:ADD a new Contraceptive Method"_$S(APCDC:";E:Edit an Existing Contraceptive Method;D:Delete an Existing Contraceptive Method",1:"")_";Q:QUIT"
S DIR("A")="Which action",DIR("B")="Q" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G FM13
I Y="Q" G FM13
S Y="FM"_Y
D @Y
G FM1
FM13 ;
K Y
Q
FMA ;
NEW APCDY,DIC
S DIC("A")="Enter CONTRACEPTIVE METHOD: ",DIC="^AUTTCM(",DIC(0)="AEMQ" D ^DIC
I Y=-1 K DIC,Y Q
S APCDCMI=+Y
S DIC="^AUPNREP("_APCDREPI_",2101,"
S DA(1)=APCDREPI
S DIC("P")=$P(^DD(9000017,2101,0),U,2)
S X=APCDCMI
S DIE("NO^")=1
S DIC("DR")=""
K DD,D0,DO
D FILE^DICN
S DIE("NO^")=1
S (APCDY,DA)=+Y,DA(1)=APCDREPI,DR=".04///^S X=$S($G(APCDDATE):$$FMTE^XLFDT(APCDDATE),1:$$FMTE^XLFDT(DT))"
S DIE="^AUPNREP("_APCDREPI_",2101,",DIE("NO^")=1
D ^DIE
I $P(^AUTTCM(APCDCMI,0),U,1)'="NONE" D
.S DA=APCDY,DA(1)=APCDREPI,DR=".02R;.03"
.S DIE="^AUPNREP("_APCDREPI_",2101,",DIE("NO^")=1
.D ^DIE
I $P(^AUTTCM(APCDCMI,0),U,1)="NONE" D
.S DA=APCDY,DA(1)=APCDREPI,DR=".02;.03"
.S DIE="^AUPNREP("_APCDREPI_",2101,",DIE("NO^")=1
.D ^DIE
S DA=APCDY,DA(1)=APCDREPI,DR=".06"
S DIE="^AUPNREP("_APCDREPI_",2101,",DIE("NO^")=1
D ^DIE
I $P(^AUPNREP(APCDREPI,2101,APCDY,0),U,3)]"" D
.S DA(1)=APCDREPI,DA=APCDY,DR=".05",DIE="^AUPNREP("_APCDREPI_",2101," D ^DIE
K DIE,DR,DA
Q
FME ;
NEW APCDY
D EN^DDIOL("","","!")
K DIR
S DIR(0)="N^1:"_APCDC_":0",DIR("A")="Edit Which One" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
FME1 K DIC,DA,DR
NEW N
S (DA,APCDY)=APCDCM(Y),DA(1)=APCDREPI
;is this None?
S N=""
I $P(^AUTTCM($P(^AUPNREP(APCDREPI,2101,APCDY,0),U),0),U)="NONE" S N=1
S DR=".01;.02"_$S('N:"R",1:"")_";.03;.06;.04///^S X=$S($G(APCDDATE):$$FMTE^XLFDT(APCDDATE),1:$$FMTE^XLFDT(DT))"
S DIE="^AUPNREP("_APCDREPI_",2101,",DIE("NO^")=1
D ^DIE
I $P(^AUPNREP(APCDREPI,2101,APCDY,0),U,3)]"" D
.S DA(1)=APCDREPI,DA=APCDY,DR=".05",DIE="^AUPNREP("_APCDREPI_",2101," D ^DIE
K DIE,DA,DR
Q
FMD ;
D EN^DDIOL("","","!")
K DIR
S DIR(0)="N^1:"_APCDC_":0",DIR("A")="Delete Which One" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
K DIC,DA,DR
S APCDY=+Y
S DA=APCDCM(APCDY),DA(1)=APCDREPI,DR="1.01////"_DUZ_";1.02////"_$$NOW^XLFDT_";1.03"
S DIE="^AUPNREP("_APCDREPI_",2101,"
D ^DIE
K DA,DIE,DR
I $P($G(^AUPNREP(APCDREPI,2101,APCDCM(APCDY),1)),U,3)="O" D
.S DIE="^AUPNREP("_APCDREPI_",2101,"
.S DA=APCDCM(APCDY),DA(1)=APCDREPI,DR="1.04R" D ^DIE K DA,DIE
S DA=APCDCM(APCDY),DA(1)=APCDREPI D MULTOSET^APCDRF
K DA
Q
;
FMN ;;EP - called from d/e input template APCD FM (FM)
S APCDREPI=DA
D EN^XBNEW("FMN1^APCDFH1","APCDREPI;APCDDATE")
K Y
Q
FMN1 ;EP - called from XBNEW call
S APCDRFS="",APCDPARS=""
I '$D(^AUPNREP(APCDREPI)) S X=$$RFADD^APCDRF(APCDREPI) I 'X W $P(X,U,2) Q
FMN12 ;
D FM1
K Y
Q
EDC ;EP - called from d/e input template APCD EDC (EDC)
S APCDREPI=DA
D EN^XBNEW("EDC1^APCDFH1","APCDREPI;APCDDATE")
K Y
Q
EDC1 ;EP - called from XBNEW call
S APCDRFS="",APCDPARS=""
I '$D(^AUPNREP(APCDREPI)) S X=$$RFADD^APCDRF(APCDREPI) I 'X W $P(X,U,2) Q
EDC11 ;
S DIE="^AUPNREP(",DA=APCDREPI,DR="[APCD EDC EDIT]" D ^DIE
K DIE,DA,DR
K Y
Q
LMP ;EP - called from d/e input template APCD LMP (LMP)
S APCDREPI=DA
D EN^XBNEW("LMP1^APCDFH1","APCDREPI;APCDDATE")
K Y
Q
LMP1 ;EP - called from XBNEW call
S APCDRFS="",APCDPARS=""
I '$D(^AUPNREP(APCDREPI)) S X=$$RFADD^APCDRF(APCDREPI) I 'X W $P(X,U,2) Q
LMP11 ;
S DIE="^AUPNREP(",DA=APCDREPI,DR="[APCD LMP EDIT]" D ^DIE
K DIE,DA,DR
K Y
Q
DELETE ;EP
I 'APCDRCNT D EN^DDIOL("No Family History to Edit",,"!!") H 3 D BACK^APCDFH Q
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No FAMILY HISTORY entry selected." Q
S APCDP=$O(VALMY(0)) I 'APCDP K APCDP,VALMY,XQORNOD W !,"No record selected." D BACK^APCDFH Q
S (APCDFHI,APCDRELI)=0
S (X,Y)=0 F S X=$O(APCDFHA("IDX",X)) Q:X'=+X!(APCDFHI) I $O(APCDFHA("IDX",X,0))=APCDP S Y=$O(APCDFHA("IDX",X,0)),APCDFHI=$P(APCDFHA("IDX",X,Y),U,1),APCDRELI=$P(APCDFHA("IDX",X,Y),U,2)
I APCDFHI=0 D D BACK^APCDFH Q
.D FULL^VALM1
.I $D(^AUPNFH("AE",APCDRELI)) W !!,"There are conditions associated with this relation, you cannot delete it." Q
.W !,"There are no conditions associated with this relation ("_$$VAL^XBDIQ1(9000014.1,APCDRELI,.01),")."
.S DIR(0)="Y",DIR("A")="Are you sure you want to delete this relation",DIR("B")="N" KILL DA D ^DIR KILL DIR
.I $D(DIRUT) Q
.I 'Y Q
.S DA=APCDRELI,DIK="^AUPNFHR(" D ^DIK
I '$D(^AUPNFH(APCDFHI,0)) W !,"Not a valid FAMILY HISTORY ENTRY." K APCDP S APCDFHI=0 D BACK^APCDFH Q
D FULL^VALM1
W !!
S DIC="^AUPNFH(",DR=0,DA=APCDFHI
D EN^DIQ
W !
S DIR(0)="Y",DIR("A")="Are you sure you want to delete this entry",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D BACK^APCDFH Q
I 'Y D BACK^APCDFH Q
S DA=APCDFHI,DIK="^AUPNFH(" D ^DIK K DIK,DA
D BACK^APCDFH
Q
;
HS ;EP - called from protocol
D FULL^VALM1
S X="" I DUZ(2),$D(^APCCCTRL(DUZ(2),0))#2 S X=$P(^(0),U,3) I X,$D(^APCHSCTL(X,0)) S X=$P(^APCHSCTL(X,0),U)
I $D(^DISV(DUZ,"^APCHSCTL(")) S Y=^("^APCHSCTL(") I $D(^APCHSCTL(Y,0)) S X=$P(^(0),U,1)
S:X="" X="ADULT REGULAR"
K DIC,DR,DD S DIC("B")=X,DIC="^APCHSCTL(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DD,D0,D1,DQ
I Y=-1 D PAUSE^APCDPL1,BACK^APCDFH Q
S APCHSTYP=+Y,APCHSPAT=APCDPAT
S APCDHDR="PCC Health Summary for "_$P(^DPT(APCHSPAT,0),U)
D VIEWR^XBLM("EN^APCHS",APCDHDR)
S (DFN,Y)=APCDPAT D ^AUPNPAT
K APCHSPAT,APCHSTYP,APCHSTAT,APCHSMTY,AMCHDAYS,AMCHDOB,APCDHDR
D BACK^APCDFH
Q
WTPRE ;EP - CALLED FROM INPUT TEMPLATE
W !!,"Patient documented as premenarchal, If they are no longer premenarchal change Patient Premenarchal field response to 'No.'",!,"You can use either the RF or FP mnemonics to change the value to 'No'.",!
Q
APCDFH1 ; IHS/CMI/LAB - LIST MANAGER API'S FOR FAMILY HISTORY AND API FOR REP FACTORS 19 Jun 2008 2:14 PM ;
+1 ;;2.0;IHS PCC SUITE;**2,7,10,11,17**;MAY 14, 2009;Build 18
+2 ;
+3 ;
FM ;EP - called from d/e input template APCD FP (FP)
+1 SET APCDREPI=DA
+2 DO EN^XBNEW("FM1^APCDFH","APCDREPI;APCDDATE")
+3 KILL Y
+4 QUIT
FM1 ;EP - called from XBNEW call
+1 SET APCDC=0
KILL APCDCM
+2 WRITE !!,"Contraceptive Methods currently recorded:"
+3 IF '$ORDER(^AUPNREP(APCDREPI,2101,0))
SET APCDC=0
WRITE " None recorded"
GOTO FM12
+4 DO EN^DDIOL("Contraceptive Method","","!?3")
DO EN^DDIOL("Start Date","","?43")
DO EN^DDIOL("End Date","","?63")
+5 DO EN^DDIOL($$REPEAT^XLFSTR("-",75),"","!?3")
+6 KILL APCDCM
SET X=0
SET APCDC=0
FOR
SET X=$ORDER(^AUPNREP(APCDREPI,2101,X))
IF X'=+X
QUIT
Begin DoDot:1
+7 ;DELETED
IF $PIECE($GET(^AUPNREP(APCDREPI,2101,X,1)),U,1)]""
QUIT
+8 SET APCDC=APCDC+1
SET APCDCM(APCDC)=X
+9 WRITE !?2,APCDC,") ",$PIECE(^AUTTCM($PIECE(^AUPNREP(APCDREPI,2101,X,0),U),0),U),?43,$$FMTE^XLFDT($PIECE(^AUPNREP(APCDREPI,2101,X,0),U,2)),?63,$$FMTE^XLFDT($PIECE(^AUPNREP(APCDREPI,2101,X,0),U,3))
+10 IF $PIECE(^AUPNREP(APCDREPI,2101,X,0),U,6)]""
WRITE !?4,"Comment: ",$PIECE(^AUPNREP(APCDREPI,2101,X,0),U,6)
+11 IF $PIECE(^AUPNREP(APCDREPI,2101,X,0),U,7)]""
WRITE !?4,"Reason Discontinued: ",$PIECE(^AUPNREP(APCDREPI,2101,X,0),U,7)
End DoDot:1
FM12 ;
+1 DO EN^DDIOL("","","!!")
+2 KILL DIR
+3 SET DIR(0)="S^A:ADD a new Contraceptive Method"_$SELECT(APCDC:";E:Edit an Existing Contraceptive Method;D:Delete an Existing Contraceptive Method",1:"")_";Q:QUIT"
+4 SET DIR("A")="Which action"
SET DIR("B")="Q"
KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
GOTO FM13
+6 IF Y="Q"
GOTO FM13
+7 SET Y="FM"_Y
+8 DO @Y
+9 GOTO FM1
FM13 ;
+1 KILL Y
+2 QUIT
FMA ;
+1 NEW APCDY,DIC
+2 SET DIC("A")="Enter CONTRACEPTIVE METHOD: "
SET DIC="^AUTTCM("
SET DIC(0)="AEMQ"
DO ^DIC
+3 IF Y=-1
KILL DIC,Y
QUIT
+4 SET APCDCMI=+Y
+5 SET DIC="^AUPNREP("_APCDREPI_",2101,"
+6 SET DA(1)=APCDREPI
+7 SET DIC("P")=$PIECE(^DD(9000017,2101,0),U,2)
+8 SET X=APCDCMI
+9 SET DIE("NO^")=1
+10 SET DIC("DR")=""
+11 KILL DD,D0,DO
+12 DO FILE^DICN
+13 SET DIE("NO^")=1
+14 SET (APCDY,DA)=+Y
SET DA(1)=APCDREPI
SET DR=".04///^S X=$S($G(APCDDATE):$$FMTE^XLFDT(APCDDATE),1:$$FMTE^XLFDT(DT))"
+15 SET DIE="^AUPNREP("_APCDREPI_",2101,"
SET DIE("NO^")=1
+16 DO ^DIE
+17 IF $PIECE(^AUTTCM(APCDCMI,0),U,1)'="NONE"
Begin DoDot:1
+18 SET DA=APCDY
SET DA(1)=APCDREPI
SET DR=".02R;.03"
+19 SET DIE="^AUPNREP("_APCDREPI_",2101,"
SET DIE("NO^")=1
+20 DO ^DIE
End DoDot:1
+21 IF $PIECE(^AUTTCM(APCDCMI,0),U,1)="NONE"
Begin DoDot:1
+22 SET DA=APCDY
SET DA(1)=APCDREPI
SET DR=".02;.03"
+23 SET DIE="^AUPNREP("_APCDREPI_",2101,"
SET DIE("NO^")=1
+24 DO ^DIE
End DoDot:1
+25 SET DA=APCDY
SET DA(1)=APCDREPI
SET DR=".06"
+26 SET DIE="^AUPNREP("_APCDREPI_",2101,"
SET DIE("NO^")=1
+27 DO ^DIE
+28 IF $PIECE(^AUPNREP(APCDREPI,2101,APCDY,0),U,3)]""
Begin DoDot:1
+29 SET DA(1)=APCDREPI
SET DA=APCDY
SET DR=".05"
SET DIE="^AUPNREP("_APCDREPI_",2101,"
DO ^DIE
End DoDot:1
+30 KILL DIE,DR,DA
+31 QUIT
FME ;
+1 NEW APCDY
+2 DO EN^DDIOL("","","!")
+3 KILL DIR
+4 SET DIR(0)="N^1:"_APCDC_":0"
SET DIR("A")="Edit Which One"
KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
QUIT
FME1 KILL DIC,DA,DR
+1 NEW N
+2 SET (DA,APCDY)=APCDCM(Y)
SET DA(1)=APCDREPI
+3 ;is this None?
+4 SET N=""
+5 IF $PIECE(^AUTTCM($PIECE(^AUPNREP(APCDREPI,2101,APCDY,0),U),0),U)="NONE"
SET N=1
+6 SET DR=".01;.02"_$SELECT('N:"R",1:"")_";.03;.06;.04///^S X=$S($G(APCDDATE):$$FMTE^XLFDT(APCDDATE),1:$$FMTE^XLFDT(DT))"
+7 SET DIE="^AUPNREP("_APCDREPI_",2101,"
SET DIE("NO^")=1
+8 DO ^DIE
+9 IF $PIECE(^AUPNREP(APCDREPI,2101,APCDY,0),U,3)]""
Begin DoDot:1
+10 SET DA(1)=APCDREPI
SET DA=APCDY
SET DR=".05"
SET DIE="^AUPNREP("_APCDREPI_",2101,"
DO ^DIE
End DoDot:1
+11 KILL DIE,DA,DR
+12 QUIT
FMD ;
+1 DO EN^DDIOL("","","!")
+2 KILL DIR
+3 SET DIR(0)="N^1:"_APCDC_":0"
SET DIR("A")="Delete Which One"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
QUIT
+5 KILL DIC,DA,DR
+6 SET APCDY=+Y
+7 SET DA=APCDCM(APCDY)
SET DA(1)=APCDREPI
SET DR="1.01////"_DUZ_";1.02////"_$$NOW^XLFDT_";1.03"
+8 SET DIE="^AUPNREP("_APCDREPI_",2101,"
+9 DO ^DIE
+10 KILL DA,DIE,DR
+11 IF $PIECE($GET(^AUPNREP(APCDREPI,2101,APCDCM(APCDY),1)),U,3)="O"
Begin DoDot:1
+12 SET DIE="^AUPNREP("_APCDREPI_",2101,"
+13 SET DA=APCDCM(APCDY)
SET DA(1)=APCDREPI
SET DR="1.04R"
DO ^DIE
KILL DA,DIE
End DoDot:1
+14 SET DA=APCDCM(APCDY)
SET DA(1)=APCDREPI
DO MULTOSET^APCDRF
+15 KILL DA
+16 QUIT
+17 ;
FMN ;;EP - called from d/e input template APCD FM (FM)
+1 SET APCDREPI=DA
+2 DO EN^XBNEW("FMN1^APCDFH1","APCDREPI;APCDDATE")
+3 KILL Y
+4 QUIT
FMN1 ;EP - called from XBNEW call
+1 SET APCDRFS=""
SET APCDPARS=""
+2 IF '$DATA(^AUPNREP(APCDREPI))
SET X=$$RFADD^APCDRF(APCDREPI)
IF 'X
WRITE $PIECE(X,U,2)
QUIT
FMN12 ;
+1 DO FM1
+2 KILL Y
+3 QUIT
EDC ;EP - called from d/e input template APCD EDC (EDC)
+1 SET APCDREPI=DA
+2 DO EN^XBNEW("EDC1^APCDFH1","APCDREPI;APCDDATE")
+3 KILL Y
+4 QUIT
EDC1 ;EP - called from XBNEW call
+1 SET APCDRFS=""
SET APCDPARS=""
+2 IF '$DATA(^AUPNREP(APCDREPI))
SET X=$$RFADD^APCDRF(APCDREPI)
IF 'X
WRITE $PIECE(X,U,2)
QUIT
EDC11 ;
+1 SET DIE="^AUPNREP("
SET DA=APCDREPI
SET DR="[APCD EDC EDIT]"
DO ^DIE
+2 KILL DIE,DA,DR
+3 KILL Y
+4 QUIT
LMP ;EP - called from d/e input template APCD LMP (LMP)
+1 SET APCDREPI=DA
+2 DO EN^XBNEW("LMP1^APCDFH1","APCDREPI;APCDDATE")
+3 KILL Y
+4 QUIT
LMP1 ;EP - called from XBNEW call
+1 SET APCDRFS=""
SET APCDPARS=""
+2 IF '$DATA(^AUPNREP(APCDREPI))
SET X=$$RFADD^APCDRF(APCDREPI)
IF 'X
WRITE $PIECE(X,U,2)
QUIT
LMP11 ;
+1 SET DIE="^AUPNREP("
SET DA=APCDREPI
SET DR="[APCD LMP EDIT]"
DO ^DIE
+2 KILL DIE,DA,DR
+3 KILL Y
+4 QUIT
DELETE ;EP
+1 IF 'APCDRCNT
DO EN^DDIOL("No Family History to Edit",,"!!")
HANG 3
DO BACK^APCDFH
QUIT
+2 DO EN^VALM2(XQORNOD(0),"OS")
+3 IF '$DATA(VALMY)
WRITE !,"No FAMILY HISTORY entry selected."
QUIT
+4 SET APCDP=$ORDER(VALMY(0))
IF 'APCDP
KILL APCDP,VALMY,XQORNOD
WRITE !,"No record selected."
DO BACK^APCDFH
QUIT
+5 SET (APCDFHI,APCDRELI)=0
+6 SET (X,Y)=0
FOR
SET X=$ORDER(APCDFHA("IDX",X))
IF X'=+X!(APCDFHI)
QUIT
IF $ORDER(APCDFHA("IDX",X,0))=APCDP
SET Y=$ORDER(APCDFHA("IDX",X,0))
SET APCDFHI=$PIECE(APCDFHA("IDX",X,Y),U,1)
SET APCDRELI=$PIECE(APCDFHA("IDX",X,Y),U,2)
+7 IF APCDFHI=0
Begin DoDot:1
+8 DO FULL^VALM1
+9 IF $DATA(^AUPNFH("AE",APCDRELI))
WRITE !!,"There are conditions associated with this relation, you cannot delete it."
QUIT
+10 WRITE !,"There are no conditions associated with this relation ("_$$VAL^XBDIQ1(9000014.1,APCDRELI,.01),")."
+11 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete this relation"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+12 IF $DATA(DIRUT)
QUIT
+13 IF 'Y
QUIT
+14 SET DA=APCDRELI
SET DIK="^AUPNFHR("
DO ^DIK
End DoDot:1
DO BACK^APCDFH
QUIT
+15 IF '$DATA(^AUPNFH(APCDFHI,0))
WRITE !,"Not a valid FAMILY HISTORY ENTRY."
KILL APCDP
SET APCDFHI=0
DO BACK^APCDFH
QUIT
+16 DO FULL^VALM1
+17 WRITE !!
+18 SET DIC="^AUPNFH("
SET DR=0
SET DA=APCDFHI
+19 DO EN^DIQ
+20 WRITE !
+21 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete this entry"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+22 IF $DATA(DIRUT)
DO BACK^APCDFH
QUIT
+23 IF 'Y
DO BACK^APCDFH
QUIT
+24 SET DA=APCDFHI
SET DIK="^AUPNFH("
DO ^DIK
KILL DIK,DA
+25 DO BACK^APCDFH
+26 QUIT
+27 ;
HS ;EP - called from protocol
+1 DO FULL^VALM1
+2 SET X=""
IF DUZ(2)
IF $DATA(^APCCCTRL(DUZ(2),0))#2
SET X=$PIECE(^(0),U,3)
IF X
IF $DATA(^APCHSCTL(X,0))
SET X=$PIECE(^APCHSCTL(X,0),U)
+3 IF $DATA(^DISV(DUZ,"^APCHSCTL("))
SET Y=^("^APCHSCTL(")
IF $DATA(^APCHSCTL(Y,0))
SET X=$PIECE(^(0),U,1)
+4 IF X=""
SET X="ADULT REGULAR"
+5 KILL DIC,DR,DD
SET DIC("B")=X
SET DIC="^APCHSCTL("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DD,D0,D1,DQ
+6 IF Y=-1
DO PAUSE^APCDPL1
DO BACK^APCDFH
QUIT
+7 SET APCHSTYP=+Y
SET APCHSPAT=APCDPAT
+8 SET APCDHDR="PCC Health Summary for "_$PIECE(^DPT(APCHSPAT,0),U)
+9 DO VIEWR^XBLM("EN^APCHS",APCDHDR)
+10 SET (DFN,Y)=APCDPAT
DO ^AUPNPAT
+11 KILL APCHSPAT,APCHSTYP,APCHSTAT,APCHSMTY,AMCHDAYS,AMCHDOB,APCDHDR
+12 DO BACK^APCDFH
+13 QUIT
WTPRE ;EP - CALLED FROM INPUT TEMPLATE
+1 WRITE !!,"Patient documented as premenarchal, If they are no longer premenarchal change Patient Premenarchal field response to 'No.'",!,"You can use either the RF or FP mnemonics to change the value to 'No'.",!
+2 QUIT
