APCDFH ; IHS/CMI/LAB - LIST MANAGER API'S FOR FAMILY HISTORY AND API FOR REP FACTORS
;;2.0;IHS PCC SUITE;**2,5,7,10,11,16**;MAY 14, 2009;Build 9
;
MAIN ;EP - main routine driver
D ASK
Q:'$G(APCDPAT)
D REFRESH(APCDPAT)
Q
;
REFRESH(PAT) ;
D TERM^VALM0
D CLEAR^VALM1
S DFN=PAT
Q:'$D(^AUPNPAT(PAT))
Q:'$D(^DPT(PAT))
S Y=PAT
D ^AUPNPAT
D LM
Q
;
EN(P,D) ;PEP - CALLED FROM OTHER MODULES
I '$G(P) Q
I '$D(^DPT(P)) Q
D EN^XBNEW("EN1^APCDFH","P;D;VALM*")
Q
EN1 ;
S (APCDF,APCDPAT)=P
S APCDDATE=$P($G(D),".")
D REFRESH(P)
Q
LM ;
S VALMCC=1
D EN^VALM("APCD FAMILY HISTORY"),CLEAR^VALM1
Q
;
SET ;
S APCDLINE=APCDLINE+1,APCDFHA(APCDLINE,0)=APCDX,APCDFHA("IDX",APCDLINE,APCDRCNT)=APCDIEN_U_R
Q
;
GETPAT(PAT) ;
K APCDFHA,APCDFHR,APCDTFH
S (APCDCNT,APCDRCNT,APCDLINE)=0
I '$O(^AUPNFH("AC",PAT,0)),'$O(^AUPNFHR("AA",PAT,0)) D Q
. S APCDFHA(1,0)="No Family History currently on file"
. S APCDRCNT=0
S APCDIEN=0 F S APCDIEN=$O(^AUPNFH("AC",PAT,APCDIEN)) Q:'APCDIEN D
.Q:'$D(^AUPNFH(APCDIEN,0))
.S R=$P(^AUPNFH(APCDIEN,0),U,9),O=""
.I R="" S R="Z",S=$$VAL^XBDIQ1(9000014,APCDIEN,.07),Z=S_" ",O=8 D G GETPAT1
..I S="" S S="UNKNOWN",Z="UNKNOWN "
.I R]"" S S=$$VAL^XBDIQ1(9000014.1,R,.01),Z=S_" "_$P(^AUPNFHR(R,0),U,3) D
..S O=$P(^AUPNFHR(R,0),U) I O S O=$P($G(^AUTTRLSH(O,21)),U,3)
..I 'O S O=8
GETPAT1 .S APCDTFH(O,S,Z,R,(9999999-$P(^AUPNFH(APCDIEN,0),U,3)),APCDIEN)=""
S X=0 F S X=$O(^AUPNFHR("AA",PAT,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNFHR("AA",PAT,X,Y)) Q:Y'=+Y D
.I '$D(^AUPNFH("AE",Y)) D
..S R=Y
..S S=$$VAL^XBDIQ1(9000014.1,R,.01),Z=S_" "_$P(^AUPNFHR(R,0),U,3)
..S O=$P(^AUPNFHR(R,0),U) I O S O=$P($G(^AUTTRLSH(O,21)),U,3)
..I 'O S O=8
..S APCDTFH(O,S,Z,R,(9999999-$P(^AUPNFHR(R,0),U,9)),0)=""
S O=0 F S O=$O(APCDTFH(O)) Q:O'=+O D
.S S="" F S S=$O(APCDTFH(O,S)) Q:S="" D
..S Z="" F S Z=$O(APCDTFH(O,S,Z)) Q:Z="" D
...S R="",C=0 F S R=$O(APCDTFH(O,S,Z,R)) Q:R="" D
....S D="" F S D=$O(APCDTFH(O,S,Z,R,D)) Q:D="" D
.....S APCDIEN="" F S APCDIEN=$O(APCDTFH(O,S,Z,R,D,APCDIEN)) Q:APCDIEN="" D FH
Q
;
STAT(I,R) ;
I R Q $$VAL^XBDIQ1(9000014.1,R,.04)
Q $$VAL^XBDIQ1(9000014,I,.06)
;
FH ;--
S APCDX="",APCDRCNT=APCDRCNT+1
S APCDLDM=$$LDM(APCDIEN) I APCDLDM="",R S APCDLDM=$P(^AUPNFHR(R,0),U,9)
;
S APCDX=APCDRCNT_")",$E(APCDX,5)=$$FMTE^XLFDT(APCDLDM)_" Relation: "_Z ;$$VAL^XBDIQ1(9000014.1,R,.04)
D SET
S APCDX="",$E(APCDX,5)="Status: "_$$STAT(APCDIEN,R) D SET
I R'=+R G FH1
I R,$P(^AUPNFHR(R,0),U,5)]""!($P(^AUPNFHR(R,0),U,6)]"") D
.S APCDX="",$E(APCDX,5)="Age at Death: "_$$VAL^XBDIQ1(9000014.1,R,.05)_" Cause of Death: "_$P(^AUPNFHR(R,0),U,6)
.D SET
I R,$P(^AUPNFHR(R,0),U,7)]""!($P(^AUPNFHR(R,0),U,8)]"") D
.S APCDX="",$E(APCDX,5)="Multiple Birth: "_$$VAL^XBDIQ1(9000014.1,R,.07)_$S($P(^AUPNFHR(R,0),U,7)="Y":" Multiple Birth Type: "_$$VAL^XBDIQ1(9000014.1,R,.08),1:"")
.D SET
FH1 S APCDX="",$E(APCDX,5)="Dx: "_$$VAL^XBDIQ1(9000014,APCDIEN,.01)_" "_$$GET1^DIQ(9000014,APCDIEN,.04)
D SET
S APCDX="",$E(APCDX,5)="SNOMED: "_$$VALI^XBDIQ1(9000014,APCDIEN,.13)
D SET
S APCDX="",$E(APCDX,5)="Age at Onset: "_$$VAL^XBDIQ1(9000014,APCDIEN,.05)
D SET
I APCDIEN,$P(^AUPNFH(APCDIEN,0),U,8)]"" S APCDX="",$E(APCDX,5)="Provider who Documented: "_$$VAL^XBDIQ1(9000014,APCDIEN,.08) D SET
Q
LDM(I) ;
I $G(I)="" Q ""
I I=0 Q ""
I '$D(^AUPNFH(I,0)) Q ""
NEW J,D,E
S D=""
S J=$P(^AUPNFH(I,0),U,9) I J S D=$P($G(^AUPNFHR(J,0)),U,9) I D="" S D=$P($G(^AUPNFHR(J,0)),U,9)
S E=$P(^AUPNFH(I,0),U,12) I E>D S D=E
S E=$P(^AUPNFH(I,0),U,3) I E>D S D=E
Q D
;
HDR ;EP
K VALMHDR
S VALMHDR(1)="Name: "_$E($P(^DPT(AUPNPAT,0),U),1,30)
S VALMHDR(1)=VALMHDR(1)_" DOB: "_$$FTIME^VALM1(AUPNDOB)_" Sex: "
S VALMHDR(1)=VALMHDR(1)_$P(^DPT(AUPNPAT,0),U,2)_" HRN: "
S VALMHDR(1)=VALMHDR(1)_$S($D(^AUPNPAT(AUPNPAT,41,DUZ(2),0)):$P(^AUPNPAT(AUPNPAT,41,DUZ(2),0),U,2),1:"????")
Q
;
ASK ;
W !
S AUPNLK("INAC")=""
S APCDPAT=""
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC
Q:Y<0
S (APCDF,APCDPAT)=+Y
K AUPNLK
Q
;
INIT ;
S VALMSG="Q - Quit/?? for more actions/+ next/- previous"
D GETPAT(APCDPAT)
K VALMHDR
S VALMCNT=APCDLINE
Q
;
ADD ;--
D FULL^VALM1
K APCDADD,APCDICD
K APCDREL,DIR
S APCDSEC=0
D EN^DDIOL(,,"!")
S DIR(0)="9000014.1,.01",DIR("A")="Enter RELATION" KILL DA D ^DIR
I $D(DIRUT) D EN^DDIOL("no relation entered, it is required ....exiting") D PAUSE,BACK Q
I Y="" D EN^DDIOL("no relationship entered, it is required ....exiting") D PAUSE,BACK Q
S APCDREL=+Y
ADD1 ;
I $P($G(^AUTTRLSH(APCDREL,21)),U,2) D I Q D ADDX,PAUSE,BACK Q
.S Q=0
.K APCDR S C=0
.S X=0 F S X=$O(^AUPNFHR("AA",APCDPAT,APCDREL,X)) Q:X'=+X D
..S C=C+1,APCDR(C)=$$VAL^XBDIQ1(9000014.1,X,.01)_" "_$P(^AUPNFHR(X,0),U,3)_" "_$$VAL^XBDIQ1(9000014.1,X,.04)_U_X
.I C=0 D ADDFHR Q
.S X=0 F S X=$O(APCDR(X)) Q:X'=+X W !?5,X,") ",$P(APCDR(X),U,1)
.S N=C+1 W !?5,N,") Add new ",$P(^AUTTRLSH(APCDREL,0),U,1)
.S DIR(0)="N^1:"_N_":0",DIR("A")="Choose",DIR("B")=N KILL DA D ^DIR KILL DIR
.I $D(DIRUT) S Q=1 Q
.I Y=N D ADDFHR Q
.S APCDFHR=$P(APCDR(+Y),U,2)
I '$P($G(^AUTTRLSH(APCDREL,21)),U,2) S APCDFHR=$O(^AUPNFHR("AA",APCDPAT,APCDREL,0)) I 'APCDFHR D ADDFHR
I 'APCDFHR G ADD1
S DIE="^AUPNFHR(",DR="[APCD FAMILY HX MEMBER EDIT]",DA=APCDFHR D ^DIE K DA,DIE,DR
;
COND ;
S DIR(0)="Y",DIR("A")="Add "_$S(APCDSEC:"Another",1:"a")_" Condition for "_$$VAL^XBDIQ1(9000014.1,APCDFHR,.01)_" "_$P(^AUPNFHR(APCDFHR,0),U,3),DIR("B")=$S(APCDSEC:"N",1:"Y") KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"No condition entered." D PAUSE,ADDX,BACK Q
I 'Y D ADDX,BACK Q
;CODE HERE TO GET SNOMED
S APCDICD="" K APCDAICD
D SMDX
Y I $G(APCDCI)="" W !,"SNOMED is required." G COND
I $G(APCDICD)="" W !,"A valid code was not selected." G COND
COND1 ;
K DIC,DR,DA
K DD,DO
S DIC="^AUPNFH(",DIC(0)="L",X=APCDICD,DIC("DR")=".02////"_APCDPAT_";.03////^S X=DT;.12////^S X=DT;.09////"_APCDFHR_";.13///"_APCDCI_";.14///"_APCDDI
D FILE^DICN
K DIC,DA,DR,DD,DO,D0,DIE
S APCDFH=+Y
K Y
S APCDOVRR=1
W !,"This is the ICD code that the SNOMED maps to, you can change it if needed.",!
S DIE="^AUPNFH(",DR=".01",DA=APCDFH D ^DIE K DIE,DA,DR
;
X ;
;
S Y=$$GETNARR^APCDFHS()
I Y="" D
.S Y=$P($$ICDDX^ICDEX(APCDICD,DT),U,4) W " ",Y
S Y=Y_"|"_APCDDI,Y=$TR(Y,";",":")
S DA=APCDFH,DIE="^AUPNFH(",DR=".04///"_Y_";.08;.05;.15" D ^DIE K DA,DR,DIE
;now put in additional icd codes if there are any
S APCDX=0 F S APCDX=$O(APCDAICD(APCDX)) Q:APCDX'=+APCDX D
.S DA(1)=APCDFH
.S X=APCDAICD(APCDX),X=$P($$ICDDX^ICDEX(X),U,1) Q:X="" I X]"" S X="`"_X
.S DIC="^AUPNFH("_DA(1)_",11,"
.S DIC(0)="L"
.S DIC("P")=$P(^DD(9000014,1101,0),"^",2)
.D ^DIC K DA,DIC
D EN^DDIOL("Family History added. ",,"!!")
K APCDOVRR,DIR
S APCDSEC=1
G COND
;
SMDX ;
S (APCDCI,APCDDI,APCDPT,APCDICD)=""
D ^APCDFHS
C I APCDCI="" W !!,"No SNOMED selected." Q
;get icd code for this snomed
S A=0
I APCDICD]"" S APCDICD=$P($$ICDDX^ICDEX(APCDICD),U,1) Q
W !!,"There was no map to an ICD Diagnosis code for that SNOMED term, you "
W !,"will need to select an ICD Diagnosis code for this Family History.",!
I $T(^APCDFHD)="" D
.S DIR(0)="9000014,.01",DIR("A")="Enter Condition" KILL DA D ^DIR KILL DIR
.I $D(DIRUT) D EN^DDIOL("no diagnosis selected....required") Q
.S APCDICD=+Y
Q
ADDX ;
K APCDFHR,APCDREL,APCDFH,APCDSEC,APCDOVRR,DIR,DA,DR,APCDICD,APCDR
D ^XBFMK
Q
;
ADDFHR ;
S APCDFHR=""
S DIR(0)="9000014.1,.03O",DIR("A")="Enter"_$S($G(APCDREL):" "_$P(^AUTTRLSH(APCDREL,0),U),1:"")_" Relation Description" KILL DA D ^DIR KILL DIR
I X="^" Q
S APCDRELD=$$UP^XLFSTR(Y)
;see if already have one
S Y=0,G=0 F S Y=$O(APCDR(Y)) Q:Y'=+Y!(G) S X=$P(APCDR(Y),U,2) I $P(^AUPNFHR(X,0),U,1)=APCDREL,$$UP^XLFSTR($P(^AUPNFHR(X,0),U,3))=APCDRELD S G=X D
.W !!,"This Relation Description ",$P(^AUTTRLSH(APCDREL,0),U,1)," ",APCDRELD," already exists."
.Q
I G Q
S APCDFHR=""
K DIC,DR,DA,DIADD,DLAYGO
K DD,DO
S DIC="^AUPNFHR(",DIC(0)="L",X=APCDREL,DIC("DR")=".02////"_APCDPAT_";.09////^S X=$S($G(APCDDATE):APCDDATE,1:DT);.03///"_APCDRELD_";.11////^S X=$S($G(APCDDATE):APCDDATE,1:DT)",DIADD=1,DLAYGO=9000014.1
D FILE^DICN
I Y=-1 W "Error in CREATING relation entry." K DIC,DR,DA,DD,D0,DO,DIADD,DLAYGO Q
S APCDFHR=+Y
K DIC,DR,DA,DD,D0,DO,DIADD,DLAYGO
Q
;
EDIT ;
I 'APCDRCNT D EN^DDIOL("No Family History to Edit",,"!!") H 3 D BACK Q
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No FAMILY HISTORY entry selected." H 2 D BACK Q
S APCDP=$O(VALMY(0)) I 'APCDP K APCDP,VALMY,XQORNOD W !,"No record selected." H 2 D BACK 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)
D FULL^VALM1
;
;first edit relation
D ^XBFMK
I APCDRELI,'APCDFHI D D BACK Q
.S DA=APCDRELI,DIE="^AUPNFHR(",DR="[APCD FAMILY HX MEMBER EDIT 1]" D ^DIE K DIE,DR,DA
.I '$D(^AUPNFHR(APCDRELI)) W !,"Relation deleted." D PAUSE Q
.S APCDSEC=0,APCDFHR=APCDRELI D COND
S APCDOREL=""
I 'APCDRELI!('APCDFHI) S Y=1 G EDIT1
I APCDRELI,APCDFHI D
.S APCDOR=$P(^AUPNFH(APCDFHI,0),U,9) I APCDOR S APCDOREL=$P(^AUPNFHR(APCDOR,0),U,1)
.W !!,"The relation associated with this Family History condition is: ",!?10,$$VAL^XBDIQ1(9000014.1,APCDRELI,.01)_" "_$P(^AUPNFHR(APCDRELI,0),U,3)
.S DIR(0)="Y",DIR("A")="Do you wish to CHANGE the relation associated with this condition",DIR("B")="N" KILL DA D ^DIR KILL DIR
.I $D(DIRUT) W !,"Exiting edit mode...." K APCDOR,APCDFHI,APCDOREL,APCDP,VALMY,XQORNOD,APCDRELI
;
I $D(DIRUT) W !,"exiting edit mode" H 2 D BACK Q
I 'Y G EDITREST
EDIT1 D EN^DDIOL(,,"!")
S DIR(0)="9000014.1,.01",DIR("A")="Enter RELATION" KILL DA D ^DIR
I $D(DIRUT) D EN^DDIOL("no relation entered, it is required ....exiting") H 1 D BACK Q
I Y="" D EN^DDIOL("no relation entered, it is required ....exiting") H 1 D BACK Q
S APCDREL=+Y
I $P($G(^AUTTRLSH(APCDREL,21)),U,2) D I Q D BACK Q
.S Q=0
.K APCDR S C=0
.S X=0 F S X=$O(^AUPNFHR("AA",APCDPAT,APCDREL,X)) Q:X'=+X D
..S C=C+1,APCDR(C)=$$VAL^XBDIQ1(9000014.1,X,.01)_" "_$P(^AUPNFHR(X,0),U,3)_" "_$$VAL^XBDIQ1(9000014.1,X,.04)_U_X
.I C=0 D ADDFHR Q
.S X=0 F S X=$O(APCDR(X)) Q:X'=+X W !?5,X,") ",$P(APCDR(X),U,1)
.S N=C+1 W !?5,N,") Add new ",$P(^AUTTRLSH(APCDREL,0),U,1)
.S DIR(0)="N^1:"_N_":0",DIR("A")="Choose",DIR("B")=N KILL DA D ^DIR KILL DIR
.I $D(DIRUT) S Q=1 Q
.I Y=N D ADDFHR Q
.S APCDFHR=$P(APCDR(Y),U,2)
.S APCDRELI=$P(APCDR(+Y),U,2)
I '$P($G(^AUTTRLSH(APCDREL,21)),U,2) S APCDFHR=$O(^AUPNFHR("AA",APCDPAT,APCDREL,0)) I 'APCDFHR D ADDFHR
I 'APCDFHR D EDITX,BACK Q
I APCDFHI S DA=APCDFHI,DIE="^AUPNFH(",DR=".09////^S X=APCDFHR" D ^DIE K DA,DR,DIE
I APCDRELI,APCDFHR'=APCDRELI D
.I $$VAL^XBDIQ1(9000014.1,APCDRELI,.01)="UNKNOWN",'$D(^AUPNFH("AE",APCDRELI)) S DA=APCDRELI,DIK="^AUPNFHR(" D ^DIK
S APCDRELI=APCDFHR
EDITREST ;
W ! S DA=APCDRELI,DIE("NO^")=1,DIE="^AUPNFHR(",DR="[APCD FAMILY HX MEMBER EDIT]" D ^DIE K DA,DIE,DR
S APCDOVRR=1
W !!
I 'APCDFHI S APCDSEC=0 D COND K APCDADD Q
W !!,"SNOMED: ",$$CONCPT^AUPNVUTL($P(^AUPNFH(APCDFHI,0),U,13))_" ("_$P(^AUPNFH(APCDFHI,0),U,13)_")"
W !,"DX: ",$$GET1^DIQ(9000014,APCDFHI,.01)
S DIR(0)="Y",DIR("A")="Do you wish to CHANGE the SNOMED or Diagnosis",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
I Y D EDITSMDX
S APCDCI=$P($G(^AUPNFH(APCDFHI,0)),U,13),APCDDI=$P(^AUPNFH(APCDFHI,0),U,14) ;I 'Y
S DA=APCDFHI,DIE="^AUPNFH(",DR=".09////^S X=APCDRELI;.12///^S X=DT;.08" D ^DIE K DA,DR,DIE
I '$D(^AUPNFH(APCDFHI,0)) D BACK Q
;I APCDCI]"" S X=$$GET1^DIQ(9000014,APCDFHI,.04)_"|"_APCDDI,DA=APCDFHI,DIE="^AUPNFH(",DR=".04///"_X D ^DIE K DA,DIE,DRIT
S DA=APCDFHI,DIE="^AUPNFH(",DR=".05;.15" D ^DIE K DA,DR,DIE
K DIE,DA,DR,APCDOVRR
D BACK
K APCDADD
Q
EDITSMDX ;
D SMDX
X1 I APCDCI="" W !,"No SNOMED selected, NO CHANGE" D PAUSE Q
S $P(^AUPNFH(APCDFHI,0),U,4)="" ;WIPE OUT PROVIDER NARRATIVE
I APCDICD]"" S DIE="^AUPNFH(",DA=APCDFHI,DR=".01////"_APCDICD D ^DIE K DIE,DA,DR
W !,"This is the ICD code that the SNOMED maps to, you can change it if needed.",!
S DIE="^AUPNFH(",DA=APCDFHI,DR=".01" D ^DIE K DA,DR,DIE
S Y=$$GETNARR^APCDFHS()
I Y="" D
.S Y=$P($$ICDDX^ICDEX(APCDICD,DT),U,4) W " ",Y
S Y=Y_"|"_APCDDI,Y=$TR(Y,";",":")
S DA=APCDFHI,DIE="^AUPNFH(",DR=".04///"_Y_";.13////"_APCDCI_";.14////"_APCDDI_";.08;.05;.15" D ^DIE K DA,DR,DIE
;.04;.13////"_APCDCI_";.14////"_APCDDI D ^DIE K DA,DR,DIE
I APCDDI]"" S X=$P(^AUTNPOV($$GET1^DIQ(9000014,APCDFHI,.04,"I"),0),U)_"|"_APCDDI,DA=APCDFHI,DIE="^AUPNFH(",DR=".04///"_X D ^DIE K DA,DIE,DR
Q
;
EDITX ;
K APCDADD,APCDOVRR,DIE,DA,DR,APCDRELI,APCDOREL,APCDFHR,APCDFHI
Q
DELETE ;
D DELETE^APCDFH1
Q
;
HS ;EP
D HS^APCDFH1
Q
BACK ;EP -BACK
D TERM^VALM0
S VALMBCK="R"
D INIT
D HDR
K DIR
K X,Y,Z,I
Q
;
HELP ;
S X="?"
D DISP^XQORM1
W !!
Q
;
EOJ ;
D CLEAR^VALM1
K APCDFHA
K AUPNADD,APCDICD,APCDFH
Q
;
;
RFADD(P) ;PEP - called to add a patient to the Reproductive Factors file
;output: DFN (ien of entry, file is dinum)
; 0^error message if add failed
I '$G(P) Q 0_"^patient DFN invalid"
I '$D(^DPT(P)) Q 0_"^patient DFN invalid"
I $P(^DPT(P,0),U,2)'="F" Q 0_"^patient not FEMALE"
I $D(^AUPNREP(P,0)) Q P
NEW X,DIC,DD,D0,DO,Y
S X=P,DIC="^AUPNREP(",DIC(0)="L"
K DD,D0,DO,DINUM
S DINUM=X
D FILE^DICN
I Y=-1 Q 0_"^fileman failed adding patient"
Q 1
;
RHEDIT(P,RETVAL) ;PEP - called to edit reproductive hx data fields
;input - DFN of patient
;output - 1 if add/edit successful
; 0^error message if error
I '$G(P) S RETVAL="0^patient DFN invalid" Q
I '$D(^DPT(P)) S RETVAL="0^patient DFN invalid" Q
I $P(^DPT(P,0),U,2)'="F" S RETVAL="0^patient not FEMALE" Q
NEW V
I '$D(^AUPNREP(P,0)) S V=$$RFADD(P) I 'V S RETVAL=V Q
NEW DA,DDS
S DA=P,DDSFILE=9000017,DR="[APCD UPDATE REPROD FACTORS" D ^DDS
I $D(DIMSG) S RETVAL="0^error in screenman" Q
S RETVAL=1
Q
;
FP ;EP - called from d/e input template APCD FP (FP)
S APCDREPI=DA
D EN^XBNEW("FP1^APCDFH","APCDREPI;APCDDATE")
K Y
Q
FP1 ;EP - called from XBNEW call
S APCDRFS="",APCDPARS=""
I '$D(^AUPNREP(APCDREPI)) S X=$$RFADD(APCDREPI) I 'X W $P(X,U,2) Q
FP11 ;
S DIE="^AUPNREP(",DA=APCDREPI,DR="[APCD FP EDIT]" D ^DIE
K DIE,DA,DR
FP12 ;
D FM1^APCDFH1
K Y
Q
;
RF ;EP
S APCDREPI=DA
D EN^XBNEW("RF1^APCDFH","APCDREPI;APCDDATE")
K Y
Q
RF1 ;EP
S APCDRFS="",APCDPARS=""
I '$D(^AUPNREP(APCDREPI)) S X=$$RFADD(APCDREPI) I 'X W $P(X,U,2) Q
RF11 ;
S DIE="^AUPNREP(",DA=APCDREPI,DR="[APCD RF EDIT]" D ^DIE
K DIE,DA,DR
K Y
Q
;
PAUSE ;EP
S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
APCDFH ; IHS/CMI/LAB - LIST MANAGER API'S FOR FAMILY HISTORY AND API FOR REP FACTORS
+1 ;;2.0;IHS PCC SUITE;**2,5,7,10,11,16**;MAY 14, 2009;Build 9
+2 ;
MAIN ;EP - main routine driver
+1 DO ASK
+2 IF '$GET(APCDPAT)
QUIT
+3 DO REFRESH(APCDPAT)
+4 QUIT
+5 ;
REFRESH(PAT) ;
+1 DO TERM^VALM0
+2 DO CLEAR^VALM1
+3 SET DFN=PAT
+4 IF '$DATA(^AUPNPAT(PAT))
QUIT
+5 IF '$DATA(^DPT(PAT))
QUIT
+6 SET Y=PAT
+7 DO ^AUPNPAT
+8 DO LM
+9 QUIT
+10 ;
EN(P,D) ;PEP - CALLED FROM OTHER MODULES
+1 IF '$GET(P)
QUIT
+2 IF '$DATA(^DPT(P))
QUIT
+3 DO EN^XBNEW("EN1^APCDFH","P;D;VALM*")
+4 QUIT
EN1 ;
+1 SET (APCDF,APCDPAT)=P
+2 SET APCDDATE=$PIECE($GET(D),".")
+3 DO REFRESH(P)
+4 QUIT
LM ;
+1 SET VALMCC=1
+2 DO EN^VALM("APCD FAMILY HISTORY")
DO CLEAR^VALM1
+3 QUIT
+4 ;
SET ;
+1 SET APCDLINE=APCDLINE+1
SET APCDFHA(APCDLINE,0)=APCDX
SET APCDFHA("IDX",APCDLINE,APCDRCNT)=APCDIEN_U_R
+2 QUIT
+3 ;
GETPAT(PAT) ;
+1 KILL APCDFHA,APCDFHR,APCDTFH
+2 SET (APCDCNT,APCDRCNT,APCDLINE)=0
+3 IF '$ORDER(^AUPNFH("AC",PAT,0))
IF '$ORDER(^AUPNFHR("AA",PAT,0))
Begin DoDot:1
+4 SET APCDFHA(1,0)="No Family History currently on file"
+5 SET APCDRCNT=0
End DoDot:1
QUIT
+6 SET APCDIEN=0
FOR
SET APCDIEN=$ORDER(^AUPNFH("AC",PAT,APCDIEN))
IF 'APCDIEN
QUIT
Begin DoDot:1
+7 IF '$DATA(^AUPNFH(APCDIEN,0))
QUIT
+8 SET R=$PIECE(^AUPNFH(APCDIEN,0),U,9)
SET O=""
+9 IF R=""
SET R="Z"
SET S=$$VAL^XBDIQ1(9000014,APCDIEN,.07)
SET Z=S_" "
SET O=8
Begin DoDot:2
+10 IF S=""
SET S="UNKNOWN"
SET Z="UNKNOWN "
End DoDot:2
GOTO GETPAT1
+11 IF R]""
SET S=$$VAL^XBDIQ1(9000014.1,R,.01)
SET Z=S_" "_$PIECE(^AUPNFHR(R,0),U,3)
Begin DoDot:2
+12 SET O=$PIECE(^AUPNFHR(R,0),U)
IF O
SET O=$PIECE($GET(^AUTTRLSH(O,21)),U,3)
+13 IF 'O
SET O=8
End DoDot:2
GETPAT1 SET APCDTFH(O,S,Z,R,(9999999-$PIECE(^AUPNFH(APCDIEN,0),U,3)),APCDIEN)=""
End DoDot:1
+1 SET X=0
FOR
SET X=$ORDER(^AUPNFHR("AA",PAT,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNFHR("AA",PAT,X,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+2 IF '$DATA(^AUPNFH("AE",Y))
Begin DoDot:2
+3 SET R=Y
+4 SET S=$$VAL^XBDIQ1(9000014.1,R,.01)
SET Z=S_" "_$PIECE(^AUPNFHR(R,0),U,3)
+5 SET O=$PIECE(^AUPNFHR(R,0),U)
IF O
SET O=$PIECE($GET(^AUTTRLSH(O,21)),U,3)
+6 IF 'O
SET O=8
+7 SET APCDTFH(O,S,Z,R,(9999999-$PIECE(^AUPNFHR(R,0),U,9)),0)=""
End DoDot:2
End DoDot:1
+8 SET O=0
FOR
SET O=$ORDER(APCDTFH(O))
IF O'=+O
QUIT
Begin DoDot:1
+9 SET S=""
FOR
SET S=$ORDER(APCDTFH(O,S))
IF S=""
QUIT
Begin DoDot:2
+10 SET Z=""
FOR
SET Z=$ORDER(APCDTFH(O,S,Z))
IF Z=""
QUIT
Begin DoDot:3
+11 SET R=""
SET C=0
FOR
SET R=$ORDER(APCDTFH(O,S,Z,R))
IF R=""
QUIT
Begin DoDot:4
+12 SET D=""
FOR
SET D=$ORDER(APCDTFH(O,S,Z,R,D))
IF D=""
QUIT
Begin DoDot:5
+13 SET APCDIEN=""
FOR
SET APCDIEN=$ORDER(APCDTFH(O,S,Z,R,D,APCDIEN))
IF APCDIEN=""
QUIT
DO FH
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
STAT(I,R) ;
+1 IF R
QUIT $$VAL^XBDIQ1(9000014.1,R,.04)
+2 QUIT $$VAL^XBDIQ1(9000014,I,.06)
+3 ;
FH ;--
+1 SET APCDX=""
SET APCDRCNT=APCDRCNT+1
+2 SET APCDLDM=$$LDM(APCDIEN)
IF APCDLDM=""
IF R
SET APCDLDM=$PIECE(^AUPNFHR(R,0),U,9)
+3 ;
+4 ;$$VAL^XBDIQ1(9000014.1,R,.04)
SET APCDX=APCDRCNT_")"
SET $EXTRACT(APCDX,5)=$$FMTE^XLFDT(APCDLDM)_" Relation: "_Z
+5 DO SET
+6 SET APCDX=""
SET $EXTRACT(APCDX,5)="Status: "_$$STAT(APCDIEN,R)
DO SET
+7 IF R'=+R
GOTO FH1
+8 IF R
IF $PIECE(^AUPNFHR(R,0),U,5)]""!($PIECE(^AUPNFHR(R,0),U,6)]"")
Begin DoDot:1
+9 SET APCDX=""
SET $EXTRACT(APCDX,5)="Age at Death: "_$$VAL^XBDIQ1(9000014.1,R,.05)_" Cause of Death: "_$PIECE(^AUPNFHR(R,0),U,6)
+10 DO SET
End DoDot:1
+11 IF R
IF $PIECE(^AUPNFHR(R,0),U,7)]""!($PIECE(^AUPNFHR(R,0),U,8)]"")
Begin DoDot:1
+12 SET APCDX=""
SET $EXTRACT(APCDX,5)="Multiple Birth: "_$$VAL^XBDIQ1(9000014.1,R,.07)_$SELECT($PIECE(^AUPNFHR(R,0),U,7)="Y":" Multiple Birth Type: "_$$VAL^XBDIQ1(9000014.1,R,.08),1:"")
+13 DO SET
End DoDot:1
FH1 SET APCDX=""
SET $EXTRACT(APCDX,5)="Dx: "_$$VAL^XBDIQ1(9000014,APCDIEN,.01)_" "_$$GET1^DIQ(9000014,APCDIEN,.04)
+1 DO SET
+2 SET APCDX=""
SET $EXTRACT(APCDX,5)="SNOMED: "_$$VALI^XBDIQ1(9000014,APCDIEN,.13)
+3 DO SET
+4 SET APCDX=""
SET $EXTRACT(APCDX,5)="Age at Onset: "_$$VAL^XBDIQ1(9000014,APCDIEN,.05)
+5 DO SET
+6 IF APCDIEN
IF $PIECE(^AUPNFH(APCDIEN,0),U,8)]""
SET APCDX=""
SET $EXTRACT(APCDX,5)="Provider who Documented: "_$$VAL^XBDIQ1(9000014,APCDIEN,.08)
DO SET
+7 QUIT
LDM(I) ;
+1 IF $GET(I)=""
QUIT ""
+2 IF I=0
QUIT ""
+3 IF '$DATA(^AUPNFH(I,0))
QUIT ""
+4 NEW J,D,E
+5 SET D=""
+6 SET J=$PIECE(^AUPNFH(I,0),U,9)
IF J
SET D=$PIECE($GET(^AUPNFHR(J,0)),U,9)
IF D=""
SET D=$PIECE($GET(^AUPNFHR(J,0)),U,9)
+7 SET E=$PIECE(^AUPNFH(I,0),U,12)
IF E>D
SET D=E
+8 SET E=$PIECE(^AUPNFH(I,0),U,3)
IF E>D
SET D=E
+9 QUIT D
+10 ;
HDR ;EP
+1 KILL VALMHDR
+2 SET VALMHDR(1)="Name: "_$EXTRACT($PIECE(^DPT(AUPNPAT,0),U),1,30)
+3 SET VALMHDR(1)=VALMHDR(1)_" DOB: "_$$FTIME^VALM1(AUPNDOB)_" Sex: "
+4 SET VALMHDR(1)=VALMHDR(1)_$PIECE(^DPT(AUPNPAT,0),U,2)_" HRN: "
+5 SET VALMHDR(1)=VALMHDR(1)_$SELECT($DATA(^AUPNPAT(AUPNPAT,41,DUZ(2),0)):$PIECE(^AUPNPAT(AUPNPAT,41,DUZ(2),0),U,2),1:"????")
+6 QUIT
+7 ;
ASK ;
+1 WRITE !
+2 SET AUPNLK("INAC")=""
+3 SET APCDPAT=""
+4 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+5 IF Y<0
QUIT
+6 SET (APCDF,APCDPAT)=+Y
+7 KILL AUPNLK
+8 QUIT
+9 ;
INIT ;
+1 SET VALMSG="Q - Quit/?? for more actions/+ next/- previous"
+2 DO GETPAT(APCDPAT)
+3 KILL VALMHDR
+4 SET VALMCNT=APCDLINE
+5 QUIT
+6 ;
ADD ;--
+1 DO FULL^VALM1
+2 KILL APCDADD,APCDICD
+3 KILL APCDREL,DIR
+4 SET APCDSEC=0
+5 DO EN^DDIOL(,,"!")
+6 SET DIR(0)="9000014.1,.01"
SET DIR("A")="Enter RELATION"
KILL DA
DO ^DIR
+7 IF $DATA(DIRUT)
DO EN^DDIOL("no relation entered, it is required ....exiting")
DO PAUSE
DO BACK
QUIT
+8 IF Y=""
DO EN^DDIOL("no relationship entered, it is required ....exiting")
DO PAUSE
DO BACK
QUIT
+9 SET APCDREL=+Y
ADD1 ;
+1 IF $PIECE($GET(^AUTTRLSH(APCDREL,21)),U,2)
Begin DoDot:1
+2 SET Q=0
+3 KILL APCDR
SET C=0
+4 SET X=0
FOR
SET X=$ORDER(^AUPNFHR("AA",APCDPAT,APCDREL,X))
IF X'=+X
QUIT
Begin DoDot:2
+5 SET C=C+1
SET APCDR(C)=$$VAL^XBDIQ1(9000014.1,X,.01)_" "_$PIECE(^AUPNFHR(X,0),U,3)_" "_$$VAL^XBDIQ1(9000014.1,X,.04)_U_X
End DoDot:2
+6 IF C=0
DO ADDFHR
QUIT
+7 SET X=0
FOR
SET X=$ORDER(APCDR(X))
IF X'=+X
QUIT
WRITE !?5,X,") ",$PIECE(APCDR(X),U,1)
+8 SET N=C+1
WRITE !?5,N,") Add new ",$PIECE(^AUTTRLSH(APCDREL,0),U,1)
+9 SET DIR(0)="N^1:"_N_":0"
SET DIR("A")="Choose"
SET DIR("B")=N
KILL DA
DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)
SET Q=1
QUIT
+11 IF Y=N
DO ADDFHR
QUIT
+12 SET APCDFHR=$PIECE(APCDR(+Y),U,2)
End DoDot:1
IF Q
DO ADDX
DO PAUSE
DO BACK
QUIT
+13 IF '$PIECE($GET(^AUTTRLSH(APCDREL,21)),U,2)
SET APCDFHR=$ORDER(^AUPNFHR("AA",APCDPAT,APCDREL,0))
IF 'APCDFHR
DO ADDFHR
+14 IF 'APCDFHR
GOTO ADD1
+15 SET DIE="^AUPNFHR("
SET DR="[APCD FAMILY HX MEMBER EDIT]"
SET DA=APCDFHR
DO ^DIE
KILL DA,DIE,DR
+16 ;
COND ;
+1 SET DIR(0)="Y"
SET DIR("A")="Add "_$SELECT(APCDSEC:"Another",1:"a")_" Condition for "_$$VAL^XBDIQ1(9000014.1,APCDFHR,.01)_" "_$PIECE(^AUPNFHR(APCDFHR,0),U,3)
SET DIR("B")=$SELECT(APCDSEC:"N",1:"Y")
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
WRITE !!,"No condition entered."
DO PAUSE
DO ADDX
DO BACK
QUIT
+3 IF 'Y
DO ADDX
DO BACK
QUIT
+4 ;CODE HERE TO GET SNOMED
+5 SET APCDICD=""
KILL APCDAICD
+6 DO SMDX
Y IF $GET(APCDCI)=""
WRITE !,"SNOMED is required."
GOTO COND
+1 IF $GET(APCDICD)=""
WRITE !,"A valid code was not selected."
GOTO COND
COND1 ;
+1 KILL DIC,DR,DA
+2 KILL DD,DO
+3 SET DIC="^AUPNFH("
SET DIC(0)="L"
SET X=APCDICD
SET DIC("DR")=".02////"_APCDPAT_";.03////^S X=DT;.12////^S X=DT;.09////"_APCDFHR_";.13///"_APCDCI_";.14///"_APCDDI
+4 DO FILE^DICN
+5 KILL DIC,DA,DR,DD,DO,D0,DIE
+6 SET APCDFH=+Y
+7 KILL Y
+8 SET APCDOVRR=1
+9 WRITE !,"This is the ICD code that the SNOMED maps to, you can change it if needed.",!
+10 SET DIE="^AUPNFH("
SET DR=".01"
SET DA=APCDFH
DO ^DIE
KILL DIE,DA,DR
+11 ;
X ;
+1 ;
+2 SET Y=$$GETNARR^APCDFHS()
+3 IF Y=""
Begin DoDot:1
+4 SET Y=$PIECE($$ICDDX^ICDEX(APCDICD,DT),U,4)
WRITE " ",Y
End DoDot:1
+5 SET Y=Y_"|"_APCDDI
SET Y=$TRANSLATE(Y,";",":")
+6 SET DA=APCDFH
SET DIE="^AUPNFH("
SET DR=".04///"_Y_";.08;.05;.15"
DO ^DIE
KILL DA,DR,DIE
+7 ;now put in additional icd codes if there are any
+8 SET APCDX=0
FOR
SET APCDX=$ORDER(APCDAICD(APCDX))
IF APCDX'=+APCDX
QUIT
Begin DoDot:1
+9 SET DA(1)=APCDFH
+10 SET X=APCDAICD(APCDX)
SET X=$PIECE($$ICDDX^ICDEX(X),U,1)
IF X=""
QUIT
IF X]""
SET X="`"_X
+11 SET DIC="^AUPNFH("_DA(1)_",11,"
+12 SET DIC(0)="L"
+13 SET DIC("P")=$PIECE(^DD(9000014,1101,0),"^",2)
+14 DO ^DIC
KILL DA,DIC
End DoDot:1
+15 DO EN^DDIOL("Family History added. ",,"!!")
+16 KILL APCDOVRR,DIR
+17 SET APCDSEC=1
+18 GOTO COND
+19 ;
SMDX ;
+1 SET (APCDCI,APCDDI,APCDPT,APCDICD)=""
+2 DO ^APCDFHS
C IF APCDCI=""
WRITE !!,"No SNOMED selected."
QUIT
+1 ;get icd code for this snomed
+2 SET A=0
+3 IF APCDICD]""
SET APCDICD=$PIECE($$ICDDX^ICDEX(APCDICD),U,1)
QUIT
+4 WRITE !!,"There was no map to an ICD Diagnosis code for that SNOMED term, you "
+5 WRITE !,"will need to select an ICD Diagnosis code for this Family History.",!
+6 IF $TEXT(^APCDFHD)=""
Begin DoDot:1
+7 SET DIR(0)="9000014,.01"
SET DIR("A")="Enter Condition"
KILL DA
DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
DO EN^DDIOL("no diagnosis selected....required")
QUIT
+9 SET APCDICD=+Y
End DoDot:1
+10 QUIT
ADDX ;
+1 KILL APCDFHR,APCDREL,APCDFH,APCDSEC,APCDOVRR,DIR,DA,DR,APCDICD,APCDR
+2 DO ^XBFMK
+3 QUIT
+4 ;
ADDFHR ;
+1 SET APCDFHR=""
+2 SET DIR(0)="9000014.1,.03O"
SET DIR("A")="Enter"_$SELECT($GET(APCDREL):" "_$PIECE(^AUTTRLSH(APCDREL,0),U),1:"")_" Relation Description"
KILL DA
DO ^DIR
KILL DIR
+3 IF X="^"
QUIT
+4 SET APCDRELD=$$UP^XLFSTR(Y)
+5 ;see if already have one
+6 SET Y=0
SET G=0
FOR
SET Y=$ORDER(APCDR(Y))
IF Y'=+Y!(G)
QUIT
SET X=$PIECE(APCDR(Y),U,2)
IF $PIECE(^AUPNFHR(X,0),U,1)=APCDREL
IF $$UP^XLFSTR($PIECE(^AUPNFHR(X,0),U,3))=APCDRELD
SET G=X
Begin DoDot:1
+7 WRITE !!,"This Relation Description ",$PIECE(^AUTTRLSH(APCDREL,0),U,1)," ",APCDRELD," already exists."
+8 QUIT
End DoDot:1
+9 IF G
QUIT
+10 SET APCDFHR=""
+11 KILL DIC,DR,DA,DIADD,DLAYGO
+12 KILL DD,DO
+13 SET DIC="^AUPNFHR("
SET DIC(0)="L"
SET X=APCDREL
SET DIC("DR")=".02////"_APCDPAT_";.09////^S X=$S($G(APCDDATE):APCDDATE,1:DT);.03///"_APCDRELD_";.11////^S X=$S($G(APCDDATE):APCDDATE,1:DT)"
SET DIADD=1
SET DLAYGO=9000014.1
+14 DO FILE^DICN
+15 IF Y=-1
WRITE "Error in CREATING relation entry."
KILL DIC,DR,DA,DD,D0,DO,DIADD,DLAYGO
QUIT
+16 SET APCDFHR=+Y
+17 KILL DIC,DR,DA,DD,D0,DO,DIADD,DLAYGO
+18 QUIT
+19 ;
EDIT ;
+1 IF 'APCDRCNT
DO EN^DDIOL("No Family History to Edit",,"!!")
HANG 3
DO BACK
QUIT
+2 DO EN^VALM2(XQORNOD(0),"OS")
+3 IF '$DATA(VALMY)
WRITE !,"No FAMILY HISTORY entry selected."
HANG 2
DO BACK
QUIT
+4 SET APCDP=$ORDER(VALMY(0))
IF 'APCDP
KILL APCDP,VALMY,XQORNOD
WRITE !,"No record selected."
HANG 2
DO BACK
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 DO FULL^VALM1
+8 ;
+9 ;first edit relation
+10 DO ^XBFMK
+11 IF APCDRELI
IF 'APCDFHI
Begin DoDot:1
+12 SET DA=APCDRELI
SET DIE="^AUPNFHR("
SET DR="[APCD FAMILY HX MEMBER EDIT 1]"
DO ^DIE
KILL DIE,DR,DA
+13 IF '$DATA(^AUPNFHR(APCDRELI))
WRITE !,"Relation deleted."
DO PAUSE
QUIT
+14 SET APCDSEC=0
SET APCDFHR=APCDRELI
DO COND
End DoDot:1
DO BACK
QUIT
+15 SET APCDOREL=""
+16 IF 'APCDRELI!('APCDFHI)
SET Y=1
GOTO EDIT1
+17 IF APCDRELI
IF APCDFHI
Begin DoDot:1
+18 SET APCDOR=$PIECE(^AUPNFH(APCDFHI,0),U,9)
IF APCDOR
SET APCDOREL=$PIECE(^AUPNFHR(APCDOR,0),U,1)
+19 WRITE !!,"The relation associated with this Family History condition is: ",!?10,$$VAL^XBDIQ1(9000014.1,APCDRELI,.01)_" "_$PIECE(^AUPNFHR(APCDRELI,0),U,3)
+20 SET DIR(0)="Y"
SET DIR("A")="Do you wish to CHANGE the relation associated with this condition"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+21 IF $DATA(DIRUT)
WRITE !,"Exiting edit mode...."
KILL APCDOR,APCDFHI,APCDOREL,APCDP,VALMY,XQORNOD,APCDRELI
End DoDot:1
+22 ;
+23 IF $DATA(DIRUT)
WRITE !,"exiting edit mode"
HANG 2
DO BACK
QUIT
+24 IF 'Y
GOTO EDITREST
EDIT1 DO EN^DDIOL(,,"!")
+1 SET DIR(0)="9000014.1,.01"
SET DIR("A")="Enter RELATION"
KILL DA
DO ^DIR
+2 IF $DATA(DIRUT)
DO EN^DDIOL("no relation entered, it is required ....exiting")
HANG 1
DO BACK
QUIT
+3 IF Y=""
DO EN^DDIOL("no relation entered, it is required ....exiting")
HANG 1
DO BACK
QUIT
+4 SET APCDREL=+Y
+5 IF $PIECE($GET(^AUTTRLSH(APCDREL,21)),U,2)
Begin DoDot:1
+6 SET Q=0
+7 KILL APCDR
SET C=0
+8 SET X=0
FOR
SET X=$ORDER(^AUPNFHR("AA",APCDPAT,APCDREL,X))
IF X'=+X
QUIT
Begin DoDot:2
+9 SET C=C+1
SET APCDR(C)=$$VAL^XBDIQ1(9000014.1,X,.01)_" "_$PIECE(^AUPNFHR(X,0),U,3)_" "_$$VAL^XBDIQ1(9000014.1,X,.04)_U_X
End DoDot:2
+10 IF C=0
DO ADDFHR
QUIT
+11 SET X=0
FOR
SET X=$ORDER(APCDR(X))
IF X'=+X
QUIT
WRITE !?5,X,") ",$PIECE(APCDR(X),U,1)
+12 SET N=C+1
WRITE !?5,N,") Add new ",$PIECE(^AUTTRLSH(APCDREL,0),U,1)
+13 SET DIR(0)="N^1:"_N_":0"
SET DIR("A")="Choose"
SET DIR("B")=N
KILL DA
DO ^DIR
KILL DIR
+14 IF $DATA(DIRUT)
SET Q=1
QUIT
+15 IF Y=N
DO ADDFHR
QUIT
+16 SET APCDFHR=$PIECE(APCDR(Y),U,2)
+17 SET APCDRELI=$PIECE(APCDR(+Y),U,2)
End DoDot:1
IF Q
DO BACK
QUIT
+18 IF '$PIECE($GET(^AUTTRLSH(APCDREL,21)),U,2)
SET APCDFHR=$ORDER(^AUPNFHR("AA",APCDPAT,APCDREL,0))
IF 'APCDFHR
DO ADDFHR
+19 IF 'APCDFHR
DO EDITX
DO BACK
QUIT
+20 IF APCDFHI
SET DA=APCDFHI
SET DIE="^AUPNFH("
SET DR=".09////^S X=APCDFHR"
DO ^DIE
KILL DA,DR,DIE
+21 IF APCDRELI
IF APCDFHR'=APCDRELI
Begin DoDot:1
+22 IF $$VAL^XBDIQ1(9000014.1,APCDRELI,.01)="UNKNOWN"
IF '$DATA(^AUPNFH("AE",APCDRELI))
SET DA=APCDRELI
SET DIK="^AUPNFHR("
DO ^DIK
End DoDot:1
+23 SET APCDRELI=APCDFHR
EDITREST ;
+1 WRITE !
SET DA=APCDRELI
SET DIE("NO^")=1
SET DIE="^AUPNFHR("
SET DR="[APCD FAMILY HX MEMBER EDIT]"
DO ^DIE
KILL DA,DIE,DR
+2 SET APCDOVRR=1
+3 WRITE !!
+4 IF 'APCDFHI
SET APCDSEC=0
DO COND
KILL APCDADD
QUIT
+5 WRITE !!,"SNOMED: ",$$CONCPT^AUPNVUTL($PIECE(^AUPNFH(APCDFHI,0),U,13))_" ("_$PIECE(^AUPNFH(APCDFHI,0),U,13)_")"
+6 WRITE !,"DX: ",$$GET1^DIQ(9000014,APCDFHI,.01)
+7 SET DIR(0)="Y"
SET DIR("A")="Do you wish to CHANGE the SNOMED or Diagnosis"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
QUIT
+9 IF Y
DO EDITSMDX
+10 ;I 'Y
SET APCDCI=$PIECE($GET(^AUPNFH(APCDFHI,0)),U,13)
SET APCDDI=$PIECE(^AUPNFH(APCDFHI,0),U,14)
+11 SET DA=APCDFHI
SET DIE="^AUPNFH("
SET DR=".09////^S X=APCDRELI;.12///^S X=DT;.08"
DO ^DIE
KILL DA,DR,DIE
+12 IF '$DATA(^AUPNFH(APCDFHI,0))
DO BACK
QUIT
+13 ;I APCDCI]"" S X=$$GET1^DIQ(9000014,APCDFHI,.04)_"|"_APCDDI,DA=APCDFHI,DIE="^AUPNFH(",DR=".04///"_X D ^DIE K DA,DIE,DRIT
+14 SET DA=APCDFHI
SET DIE="^AUPNFH("
SET DR=".05;.15"
DO ^DIE
KILL DA,DR,DIE
+15 KILL DIE,DA,DR,APCDOVRR
+16 DO BACK
+17 KILL APCDADD
+18 QUIT
EDITSMDX ;
+1 DO SMDX
X1 IF APCDCI=""
WRITE !,"No SNOMED selected, NO CHANGE"
DO PAUSE
QUIT
+1 ;WIPE OUT PROVIDER NARRATIVE
SET $PIECE(^AUPNFH(APCDFHI,0),U,4)=""
+2 IF APCDICD]""
SET DIE="^AUPNFH("
SET DA=APCDFHI
SET DR=".01////"_APCDICD
DO ^DIE
KILL DIE,DA,DR
+3 WRITE !,"This is the ICD code that the SNOMED maps to, you can change it if needed.",!
+4 SET DIE="^AUPNFH("
SET DA=APCDFHI
SET DR=".01"
DO ^DIE
KILL DA,DR,DIE
+5 SET Y=$$GETNARR^APCDFHS()
+6 IF Y=""
Begin DoDot:1
+7 SET Y=$PIECE($$ICDDX^ICDEX(APCDICD,DT),U,4)
WRITE " ",Y
End DoDot:1
+8 SET Y=Y_"|"_APCDDI
SET Y=$TRANSLATE(Y,";",":")
+9 SET DA=APCDFHI
SET DIE="^AUPNFH("
SET DR=".04///"_Y_";.13////"_APCDCI_";.14////"_APCDDI_";.08;.05;.15"
DO ^DIE
KILL DA,DR,DIE
+10 ;.04;.13////"_APCDCI_";.14////"_APCDDI D ^DIE K DA,DR,DIE
+11 IF APCDDI]""
SET X=$PIECE(^AUTNPOV($$GET1^DIQ(9000014,APCDFHI,.04,"I"),0),U)_"|"_APCDDI
SET DA=APCDFHI
SET DIE="^AUPNFH("
SET DR=".04///"_X
DO ^DIE
KILL DA,DIE,DR
+12 QUIT
+13 ;
EDITX ;
+1 KILL APCDADD,APCDOVRR,DIE,DA,DR,APCDRELI,APCDOREL,APCDFHR,APCDFHI
+2 QUIT
DELETE ;
+1 DO DELETE^APCDFH1
+2 QUIT
+3 ;
HS ;EP
+1 DO HS^APCDFH1
+2 QUIT
BACK ;EP -BACK
+1 DO TERM^VALM0
+2 SET VALMBCK="R"
+3 DO INIT
+4 DO HDR
+5 KILL DIR
+6 KILL X,Y,Z,I
+7 QUIT
+8 ;
HELP ;
+1 SET X="?"
+2 DO DISP^XQORM1
+3 WRITE !!
+4 QUIT
+5 ;
EOJ ;
+1 DO CLEAR^VALM1
+2 KILL APCDFHA
+3 KILL AUPNADD,APCDICD,APCDFH
+4 QUIT
+5 ;
+6 ;
RFADD(P) ;PEP - called to add a patient to the Reproductive Factors file
+1 ;output: DFN (ien of entry, file is dinum)
+2 ; 0^error message if add failed
+3 IF '$GET(P)
QUIT 0_"^patient DFN invalid"
+4 IF '$DATA(^DPT(P))
QUIT 0_"^patient DFN invalid"
+5 IF $PIECE(^DPT(P,0),U,2)'="F"
QUIT 0_"^patient not FEMALE"
+6 IF $DATA(^AUPNREP(P,0))
QUIT P
+7 NEW X,DIC,DD,D0,DO,Y
+8 SET X=P
SET DIC="^AUPNREP("
SET DIC(0)="L"
+9 KILL DD,D0,DO,DINUM
+10 SET DINUM=X
+11 DO FILE^DICN
+12 IF Y=-1
QUIT 0_"^fileman failed adding patient"
+13 QUIT 1
+14 ;
RHEDIT(P,RETVAL) ;PEP - called to edit reproductive hx data fields
+1 ;input - DFN of patient
+2 ;output - 1 if add/edit successful
+3 ; 0^error message if error
+4 IF '$GET(P)
SET RETVAL="0^patient DFN invalid"
QUIT
+5 IF '$DATA(^DPT(P))
SET RETVAL="0^patient DFN invalid"
QUIT
+6 IF $PIECE(^DPT(P,0),U,2)'="F"
SET RETVAL="0^patient not FEMALE"
QUIT
+7 NEW V
+8 IF '$DATA(^AUPNREP(P,0))
SET V=$$RFADD(P)
IF 'V
SET RETVAL=V
QUIT
+9 NEW DA,DDS
+10 SET DA=P
SET DDSFILE=9000017
SET DR="[APCD UPDATE REPROD FACTORS"
DO ^DDS
+11 IF $DATA(DIMSG)
SET RETVAL="0^error in screenman"
QUIT
+12 SET RETVAL=1
+13 QUIT
+14 ;
FP ;EP - called from d/e input template APCD FP (FP)
+1 SET APCDREPI=DA
+2 DO EN^XBNEW("FP1^APCDFH","APCDREPI;APCDDATE")
+3 KILL Y
+4 QUIT
FP1 ;EP - called from XBNEW call
+1 SET APCDRFS=""
SET APCDPARS=""
+2 IF '$DATA(^AUPNREP(APCDREPI))
SET X=$$RFADD(APCDREPI)
IF 'X
WRITE $PIECE(X,U,2)
QUIT
FP11 ;
+1 SET DIE="^AUPNREP("
SET DA=APCDREPI
SET DR="[APCD FP EDIT]"
DO ^DIE
+2 KILL DIE,DA,DR
FP12 ;
+1 DO FM1^APCDFH1
+2 KILL Y
+3 QUIT
+4 ;
RF ;EP
+1 SET APCDREPI=DA
+2 DO EN^XBNEW("RF1^APCDFH","APCDREPI;APCDDATE")
+3 KILL Y
+4 QUIT
RF1 ;EP
+1 SET APCDRFS=""
SET APCDPARS=""
+2 IF '$DATA(^AUPNREP(APCDREPI))
SET X=$$RFADD(APCDREPI)
IF 'X
WRITE $PIECE(X,U,2)
QUIT
RF11 ;
+1 SET DIE="^AUPNREP("
SET DA=APCDREPI
SET DR="[APCD RF EDIT]"
DO ^DIE
+2 KILL DIE,DA,DR
+3 KILL Y
+4 QUIT
+5 ;
PAUSE ;EP
+1 SET DIR(0)="EO"
SET DIR("A")="Press enter to continue...."
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 QUIT
