APCDRF ; IHS/CMI/LAB - LIST MANAGER API'S FOR FAMILY HISTORY AND API FOR REP FACTORS 19 Jun 2008 2:14 PM ; 28 Jan 2009 11:59 AM
;;2.0;IHS PCC SUITE;**2,7,11**;MAY 14, 2009;Build 58
;
;
;
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(APCDIE,APCDPT,APCDDATA,RETVAL) ;PEP - called to edit reproductive hx data fields
;input - APCDPT is DFN of patient
; APCDDATA - passed in by reference array containing fields and values to be updated and put in the FDA array.
; should be in format APCDDATA(field #)=value (either internal or external)
; either internal or external values can be passed, values will be checked for validity
; PLEASE NOTE: if you send a field in the array and the value is blank the field value will be deleted, you can also send an "@" to delete a field value
;output - ien^error message 1 if error occured|error message 2 if error occured|error message 3|etc until all errors passed back to caller
; if patient could not be added to the file the return value will be 0^error message
;note: each individual field value passed is checked for validity, those that pass will be filed, those that don't will be passed back
;with the VAL^DIE message
I '$G(APCDPT) S RETVAL="0^patient DFN invalid" Q
I '$D(^DPT(APCDPT)) S RETVAL="0^patient DFN invalid" Q
I $P(^DPT(APCDPT,0),"^",2)'="F" S RETVAL="0^patient not FEMALE" Q
I $G(APCDVAL)="" S APCDVAL="I"
I $G(APCDIE)="" S APCDIE="I" ;default to internal values if not passed in
NEW V,APCDIENS,APCDFDA,E,APCDC
S APCDC=0
I '$D(^AUPNREP(APCDPT,0)) S V=$$RFADD(APCDPT) I 'V S RETVAL=V Q
;I $G(APCDDATA)="" S RETVAL="0^no fields to edit" Q ;Q APCDPT ;no fields to edit??
I '$D(APCDDATA) S RETVAL="0^no fields to edit" Q ;Q APCDPT ;no fields to edit??
;M APCDDATA=@APCDDATA
I '$O(APCDDATA("")) S RETVAL="0^no fields in the data array" Q ;Q APCDPT ;no fields in the data array
S APCDIENS=APCDPT_","
S APCDIENS(1)=APCDPT
;let's check the values being passed in with VAL^DIE, if any are in error set error and don't set into FDA array
;guess you never know what people will try to pass
NEW APCDF,APCDV,APCDE,APCDI
I $G(APCDIE)="E" D ;if external check the validity of data
.S APCDF="" F S APCDF=$O(APCDDATA(APCDF)) Q:APCDF="" D
..I APCDF=".01" K APCDDATA(APCDF) Q ;you can't edit the .01, it's dinum'ed
..I '$D(^DD(9000017,APCDF,0)) K APCDDATA(APCDF) D E("field number not valid") Q
..S APCDV=APCDDATA(APCDF)
..Q:APCDV=""
..K APCDE,APCDI
..S APCDI=""
..D VAL^DIE(9000017,APCDIENS,APCDF,"E",APCDV,.APCDI,,"APCDE")
..I $D(APCDE("DIERR",1,"TEXT",1)) D E(APCDE("DIERR",1,"TEXT",1)) K APCDDATA(APCDF) Q
..S APCDDATA(APCDF)=APCDI
;now set FDA array with values left that are valid and call FILE^DIE
K APCDFDA
S APCDF="" F S APCDF=$O(APCDDATA(APCDF)) Q:APCDF="" D
.S APCDFDA(9000017,APCDIENS,APCDF)=APCDDATA(APCDF)
;CALL FILE^DIE
K APCDE
D FILE^DIE("K","APCDFDA","APCDE(0)")
S APCDI=0 F S APCDI=$O(APCDE(0,"DIERR",APCDI)) Q:APCDI'=+APCDI D
.Q:'$D(APCDE(0,"DIERR",APCDI,"TEXT"))
.D E(APCDE(0,"DIERR",APCDI,"TEXT"))
S RETVAL=APCDPT_"^"_RETVAL
Q
E(V) ;
S APCDC=APCDC+1,$P(RETVAL,"|",APCDC)=V
Q
;
TEST ;
S P=478
K APCDLORI,LORIERR
S APCDLORI(2)=3090101
S APCDLORI(1103)="A"
;S APCDLORI(3)="O"
S APCDLORI(3.05)=3090101
S APCDLORI(4)=3100405
S APCDLORI(4.05)="D"
S APCDLORI(1103)=5
S APCDLORI(1105)=0
S APCDLORI(1107)=5
S APCDLORI(1109)=0
S APCDLORI(1111)=""
S APCDLORI(1113)=5
S APCDLORI(1131)="XX"
S APCDLORI(1133)=""
D RHEDIT("E",P,.APCDLORI,.LORIERR)
;ZW LORIERR
Q
;
PAUSE ;EP
S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
OLDCM(%) ;EP - called from trigger
Q ""
SETTOMUL ;EP - called from trigger on 3 field
NEW APCDDA,APCDDA1
S APCDDA1=$G(D0) ;D0
Q:'APCDDA1
Q:'$D(^AUPNREP(APCDDA1,0))
D EN^XBNEW("SETTOM1^APCDRF","APCDDA1")
Q
;
NEWVAL(E) ;
NEW X,Y,APCDTEXT,APCDY
S Y=""
S APCDTEXT="CMMAP" F APCDY=1:1 S X=$T(@APCDTEXT+APCDY) Q:$P(X,";;",2)=""!(Y]"") I $P(X,";;",2)=E S Y=$P(X,";;",3)_U_$P(X,";;",4)
Q Y
;
CMMAP ;;
;;ABSTINENCE;;ABSTINENCE
;;HORMONE INJECTION;;HORMONAL/DEPO PROVERA
;;HORMONAL IMPLANT;;HORMONAL/IMPLANT
;;MENOPAUSE;;NA MENOPAUSE
;;EDUCATION ONLY;;OTHER;;1
;;ORAL CONTRACEPTIVES;;OTHER;;1
;;IUD;;OTHER;;1
;;BARRIER METHODS;;OTHER;;1
;;OTHER;;OTHER
;;NATURAL TECHNIQUES;;PERIODIC ABSTINENCE METHODS
;;SURGICAL STERILIZATION;;STERILIZATION (FEMALE)
;;PARTNER STERILIZED;;STERILIZATION (MALE)
;;NONE;;NONE
;;
SETTOM1 ;
;create multiple from fields 3, 3.05, 3.1 if it doesn't currently exist
;edit the multiple .04 if it does exist
;if 3 field null do nothing
;
NEW APCDFPV,APCDFPBD,APCDFPDT,APCDTE,APCDT,APCDCOM,APCDISNG,APCDX
S APCDCOM="",APCDISNG=1
S APCDFPV=$$VAL^XBDIQ1(9000017,APCDDA1,3)
I APCDFPV="" Q ;do nothing
S APCDFPBD=$P(^AUPNREP(APCDDA1,0),U,7)
S APCDFPDT=$P(^AUPNREP(APCDDA1,0),U,8)
;do we have this one on this begun date? if so update .04 and quit
S APCDTE=$$NEWVAL(APCDFPV) ;get external new value
I $P(APCDTE,U,1)="" Q ;no external value
S APCDT=$O(^AUTTCM("B",$P(APCDTE,U,1),0))
I APCDT="" Q
I APCDFPBD I $D(^AUPNREP("ACON",APCDDA1,APCDT,APCDFPBD)) S APCDX=$O(^AUPNREP("ACON",APCDDA1,APCDT,APCDFPBD,APCDDA1,0)) I APCDX,$P(^AUPNREP(APCDDA1,2101,APCDX,0),U,6)=APCDFPV Q ;already has this one in the multiple
I 'APCDFPBD Q:$$HASND(APCDDA1,APCDT,APCDFPV) ;already have it with no date
I $P(APCDTE,U,2) S APCDCOM=APCDFPV
;now create multiple entry
S DIC="^AUPNREP("_APCDDA1_",2101,"
S DIC(0)="L"
S DA(1)=APCDDA1
S DIC("P")=$P(^DD(9000017,2101,0),U,2)
S X=APCDT
S DIC("DR")=".02////"_APCDFPBD_";.06///"_APCDCOM ;.04///^S X=$S($G(APCDDATE):$$FMTE^XLFDT(APCDDATE),1:$$FMTE^XLFDT(DT))"
K DD,D0,DO
D FILE^DICN
K DIC,DD,DO,D0,DA
Q
HASND(X,T,C) ;DOES THIS PATIENT HAVE THIS ONE WITH NO DATE BEGUN?
NEW Y,G
S G=0
S Y=0 F S Y=$O(^AUPNREP(X,2101,Y)) Q:Y'=+Y I $P(^AUPNREP(X,2101,Y,0),U,1)=T,$P(^AUPNREP(X,2101,Y,0),U,2)="",$P(^AUPNREP(X,2101,Y,0),U,6)=C S G=1
Q G
;
MULTOSET ;EP - CALLED FROM TRIGGER
;if enter into the multiple then overlay 3, 3.05, 3.1 if date begun later than 3.05
;
NEW APCDDA,APCDDA1
S APCDDA=$G(DA) ;MULTIPLE IEN
S APCDDA1=$G(DA(1)) ;IEN
Q:'APCDDA1
Q:'APCDDA
Q:'$D(^AUPNREP(APCDDA1,0))
D EN^XBNEW("MUTOSET1^APCDRF","APCDDA1;APCDDA")
Q
;
MUTOSET1 ;
NEW APCDFPV,APCDFPBD,APCDFPDT,APCDTE,APCDT,APCDCOM,APCDINMU
S APCDCOM="",APCDINMU=1
;GET LATEST OF THE DATE BEGUNS, IF NO DATE BEGUNS THEN USE THE LAST ONE IN, IF NONE, @ FIELDS
NEW APCDCM,APCDX,APCDC,APCDDB,APCDM
S APCDX=0 F S APCDX=$O(^AUPNREP(APCDDA1,2101,APCDX)) Q:APCDX'=+APCDX D
.Q:$P($G(^AUPNREP(APCDDA1,2101,APCDX,1)),U,1)]"" ;DELETED
.S APCDC=$P(^AUPNREP(APCDDA1,2101,APCDX,0),U,1)
.Q:'APCDC
.S APCDDB=$P(^AUPNREP(APCDDA1,2101,APCDX,0),U,2)
.S APCDDE=$P(^AUPNREP(APCDDA1,2101,APCDX,0),U,3)
.S APCDCM((9999999-APCDDB),-APCDX)=""
.Q
S APCDFPBD=$O(APCDCM(""))
I 'APCDFPBD S DIE="^AUPNREP(",DA=APCDDA1,DR="3///@;3.05////@;3.1////"_DT D ^DIE K DIE,DA,DR Q
S APCDX=$O(APCDCM(APCDFPBD,""))
Q:APCDX=""
S APCDX=$P(APCDX,"-",2)
S APCDFPV=$P(^AUPNREP(APCDDA1,2101,APCDX,0),U,1)
I APCDFPV="" Q ;do nothing
S APCDFPBD=$P(^AUPNREP(APCDDA1,2101,APCDX,0),U,2) ;BEGUN
S APCDFPDT=$P(^AUPNREP(APCDDA1,2101,APCDX,0),U,4) ;UPDATED
;do we have this one on this begun date? if so update .04 and quit
S APCDTE=$P(^AUTTCM(APCDFPV,0),U,4) ;get external OLD SET value
I $$VAL^XBDIQ1(9000017,APCDDA1,3)=APCDTE D Q ;already have that method so edit date begun and date hx obtained
.S DIE="^AUPNREP(",DA=APCDDA1,DR="3.05////"_APCDFPBD_";3.1////"_DT D ^DIE K DA,DR,DIE
I APCDFPBD Q:$P(^AUPNREP(APCDDA1,0),U,7)'<APCDFPBD ;already have one with a greater date begun
S DIE="^AUPNREP(",DA=APCDDA1,DR="3///"_APCDTE_";3.05////"_APCDFPBD_";3.1////"_DT D ^DIE K DIE,DA,DR
Q
EDCTONEW ;EP
Q:$G(APCDEDDI)
Q:$G(APCDDEFI)
NEW APCDDA1
S APCDDA1=$G(D0) ;D0
Q:'APCDDA1
Q:'$D(^AUPNREP(APCDDA1,0))
D EN^XBNEW("EDCTONE1^APCDRF","APCDDA1")
Q
EDCTONE1 ;EP
NEW APCDIEDC
S APCDIEDC=1
S APCDEDD=$P(^AUPNREP(APCDDA1,0),U,9)
S APCDHOW=$P(^AUPNREP(APCDDA1,0),U,10)
I APCDHOW=""!(APCDHOW=0) D Q
.S DA=APCDDA1,DIE="^AUPNREP(",DR="1314///"_APCDEDD D ^DIE K DA,DIE,DR
I APCDHOW=1 D Q
.S DA=APCDDA1,DIE="^AUPNREP(",DR="1305////"_APCDEDD_";1314///@" D ^DIE K DIE,DA,DR
I APCDHOW=2 D Q
.S DA=APCDDA1,DIE="^AUPNREP(",DR="1302////"_APCDEDD_";1314///@" D ^DIE K DIE,DA,DR
I APCDHOW=3 D Q
.S DA=APCDDA1,DIE="^AUPNREP(",DR="1308////"_APCDEDD_";1314///@" D ^DIE K DIE,DA,DR
Q
EDDTOEDC(APCDF) ;EP - if enter EDD move to old EDC fields 4, 4.05, 4.1
I $G(APCDIEDC) Q
NEW APCDEDDI
S APCDEDDI=1
NEW APCDDA1
S APCDDA1=$G(D0) ;D0
Q:'APCDDA1
Q:'$D(^AUPNREP(APCDDA1,0))
D EN^XBNEW("EDDTOED1^APCDRF","APCDDA1;APCDF;APCDEDDI")
Q
EDDTOED1 ;
NEW APCDHOW
S APCDHOW=$S(APCDF=1314:0,APCDF=1305:1,APCDF=1302:2,APCDF=1308:3,1:"")
I APCDHOW="" Q
S DA=APCDDA1,DIE="^AUPNREP(",DR="4////"_$$VALI^XBDIQ1(9000017,APCDDA1,APCDF)_";4.05////"_APCDHOW_";4.1////"_$$NOW^XLFDT D ^DIE K DIE,DA,DR
Q
DEDD ;
I X="L",$$VAL^XBDIQ1(9000017,DA,1302)="" D Q
.D EN^DDIOL("EDD (LMP) is blank therefore the Definitive EDD cannot be L - EDD (LMP).")
.K X
I X="U",$$VAL^XBDIQ1(9000017,DA,1305)="" D Q
.D EN^DDIOL("EDD (ULTRASOUND) is blank therefore the Definitive EDD cannot be U - EDD (ULTRASOUND).")
.K X
I X="C",$$VAL^XBDIQ1(9000017,DA,1308)="" D Q
.D EN^DDIOL("EDD (CLINICAL PARAMETERS) is blank therefore the Definitive EDD cannot be C - EDD (CLINICAL PARAMETERS).")
.K X
Q
DEFEDDF4 ;EP - move definitive EDD to EDC 4, 4.05, 4.1
I $G(APCDIEDC) Q
NEW APCDDA1
S APCDDA1=$G(D0) ;D0
Q:'APCDDA1
Q:'$D(^AUPNREP(APCDDA1,0))
D EN^XBNEW("DEFEDDF^APCDRF","APCDDA1;APCDF")
Q
DEFEDDF ;
NEW APCDHOW,APCDF,APCDDEFI
S APCDDEFI=1
S APCDF=$$VALI^XBDIQ1(9000017,APCDDA1,1311)
S APCDF=$S(APCDF="L":1302,APCDF="U":1305,APCDF="C":1308,1:"")
I APCDF="" S DA=APCDDA1,DIE="^AUPNREP(",DR="4///@;4.05///@;4.1///@" D ^DIE K DIE,DA,DR Q
S APCDHOW=$S(APCDF=1314:0,APCDF=1305:1,APCDF=1302:2,APCDF=1308:3,1:"")
I APCDHOW="" Q
S DA=APCDDA1,DIE="^AUPNREP(",DR="4////"_$$VALI^XBDIQ1(9000017,APCDDA1,APCDF)_";4.05////"_APCDHOW_";4.1////"_$$NOW^XLFDT D ^DIE K DIE,DA,DR
Q
APCDRF ; IHS/CMI/LAB - LIST MANAGER API'S FOR FAMILY HISTORY AND API FOR REP FACTORS 19 Jun 2008 2:14 PM ; 28 Jan 2009 11:59 AM
+1 ;;2.0;IHS PCC SUITE;**2,7,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;
+4 ;
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(APCDIE,APCDPT,APCDDATA,RETVAL) ;PEP - called to edit reproductive hx data fields
+1 ;input - APCDPT is DFN of patient
+2 ; APCDDATA - passed in by reference array containing fields and values to be updated and put in the FDA array.
+3 ; should be in format APCDDATA(field #)=value (either internal or external)
+4 ; either internal or external values can be passed, values will be checked for validity
+5 ; PLEASE NOTE: if you send a field in the array and the value is blank the field value will be deleted, you can also send an "@" to delete a field value
+6 ;output - ien^error message 1 if error occured|error message 2 if error occured|error message 3|etc until all errors passed back to caller
+7 ; if patient could not be added to the file the return value will be 0^error message
+8 ;note: each individual field value passed is checked for validity, those that pass will be filed, those that don't will be passed back
+9 ;with the VAL^DIE message
+10 IF '$GET(APCDPT)
SET RETVAL="0^patient DFN invalid"
QUIT
+11 IF '$DATA(^DPT(APCDPT))
SET RETVAL="0^patient DFN invalid"
QUIT
+12 IF $PIECE(^DPT(APCDPT,0),"^",2)'="F"
SET RETVAL="0^patient not FEMALE"
QUIT
+13 IF $GET(APCDVAL)=""
SET APCDVAL="I"
+14 ;default to internal values if not passed in
IF $GET(APCDIE)=""
SET APCDIE="I"
+15 NEW V,APCDIENS,APCDFDA,E,APCDC
+16 SET APCDC=0
+17 IF '$DATA(^AUPNREP(APCDPT,0))
SET V=$$RFADD(APCDPT)
IF 'V
SET RETVAL=V
QUIT
+18 ;I $G(APCDDATA)="" S RETVAL="0^no fields to edit" Q ;Q APCDPT ;no fields to edit??
+19 ;Q APCDPT ;no fields to edit??
IF '$DATA(APCDDATA)
SET RETVAL="0^no fields to edit"
QUIT
+20 ;M APCDDATA=@APCDDATA
+21 ;Q APCDPT ;no fields in the data array
IF '$ORDER(APCDDATA(""))
SET RETVAL="0^no fields in the data array"
QUIT
+22 SET APCDIENS=APCDPT_","
+23 SET APCDIENS(1)=APCDPT
+24 ;let's check the values being passed in with VAL^DIE, if any are in error set error and don't set into FDA array
+25 ;guess you never know what people will try to pass
+26 NEW APCDF,APCDV,APCDE,APCDI
+27 ;if external check the validity of data
IF $GET(APCDIE)="E"
Begin DoDot:1
+28 SET APCDF=""
FOR
SET APCDF=$ORDER(APCDDATA(APCDF))
IF APCDF=""
QUIT
Begin DoDot:2
+29 ;you can't edit the .01, it's dinum'ed
IF APCDF=".01"
KILL APCDDATA(APCDF)
QUIT
+30 IF '$DATA(^DD(9000017,APCDF,0))
KILL APCDDATA(APCDF)
DO E("field number not valid")
QUIT
+31 SET APCDV=APCDDATA(APCDF)
+32 IF APCDV=""
QUIT
+33 KILL APCDE,APCDI
+34 SET APCDI=""
+35 DO VAL^DIE(9000017,APCDIENS,APCDF,"E",APCDV,.APCDI,,"APCDE")
+36 IF $DATA(APCDE("DIERR",1,"TEXT",1))
DO E(APCDE("DIERR",1,"TEXT",1))
KILL APCDDATA(APCDF)
QUIT
+37 SET APCDDATA(APCDF)=APCDI
End DoDot:2
End DoDot:1
+38 ;now set FDA array with values left that are valid and call FILE^DIE
+39 KILL APCDFDA
+40 SET APCDF=""
FOR
SET APCDF=$ORDER(APCDDATA(APCDF))
IF APCDF=""
QUIT
Begin DoDot:1
+41 SET APCDFDA(9000017,APCDIENS,APCDF)=APCDDATA(APCDF)
End DoDot:1
+42 ;CALL FILE^DIE
+43 KILL APCDE
+44 DO FILE^DIE("K","APCDFDA","APCDE(0)")
+45 SET APCDI=0
FOR
SET APCDI=$ORDER(APCDE(0,"DIERR",APCDI))
IF APCDI'=+APCDI
QUIT
Begin DoDot:1
+46 IF '$DATA(APCDE(0,"DIERR",APCDI,"TEXT"))
QUIT
+47 DO E(APCDE(0,"DIERR",APCDI,"TEXT"))
End DoDot:1
+48 SET RETVAL=APCDPT_"^"_RETVAL
+49 QUIT
E(V) ;
+1 SET APCDC=APCDC+1
SET $PIECE(RETVAL,"|",APCDC)=V
+2 QUIT
+3 ;
TEST ;
+1 SET P=478
+2 KILL APCDLORI,LORIERR
+3 SET APCDLORI(2)=3090101
+4 SET APCDLORI(1103)="A"
+5 ;S APCDLORI(3)="O"
+6 SET APCDLORI(3.05)=3090101
+7 SET APCDLORI(4)=3100405
+8 SET APCDLORI(4.05)="D"
+9 SET APCDLORI(1103)=5
+10 SET APCDLORI(1105)=0
+11 SET APCDLORI(1107)=5
+12 SET APCDLORI(1109)=0
+13 SET APCDLORI(1111)=""
+14 SET APCDLORI(1113)=5
+15 SET APCDLORI(1131)="XX"
+16 SET APCDLORI(1133)=""
+17 DO RHEDIT("E",P,.APCDLORI,.LORIERR)
+18 ;ZW LORIERR
+19 QUIT
+20 ;
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
OLDCM(%) ;EP - called from trigger
+1 QUIT ""
SETTOMUL ;EP - called from trigger on 3 field
+1 NEW APCDDA,APCDDA1
+2 ;D0
SET APCDDA1=$GET(D0)
+3 IF 'APCDDA1
QUIT
+4 IF '$DATA(^AUPNREP(APCDDA1,0))
QUIT
+5 DO EN^XBNEW("SETTOM1^APCDRF","APCDDA1")
+6 QUIT
+7 ;
NEWVAL(E) ;
+1 NEW X,Y,APCDTEXT,APCDY
+2 SET Y=""
+3 SET APCDTEXT="CMMAP"
FOR APCDY=1:1
SET X=$TEXT(@APCDTEXT+APCDY)
IF $PIECE(X,";;",2)=""!(Y]"")
QUIT
IF $PIECE(X,";;",2)=E
SET Y=$PIECE(X,";;",3)_U_$PIECE(X,";;",4)
+4 QUIT Y
+5 ;
CMMAP ;;
+1 ;;ABSTINENCE;;ABSTINENCE
+2 ;;HORMONE INJECTION;;HORMONAL/DEPO PROVERA
+3 ;;HORMONAL IMPLANT;;HORMONAL/IMPLANT
+4 ;;MENOPAUSE;;NA MENOPAUSE
+5 ;;EDUCATION ONLY;;OTHER;;1
+6 ;;ORAL CONTRACEPTIVES;;OTHER;;1
+7 ;;IUD;;OTHER;;1
+8 ;;BARRIER METHODS;;OTHER;;1
+9 ;;OTHER;;OTHER
+10 ;;NATURAL TECHNIQUES;;PERIODIC ABSTINENCE METHODS
+11 ;;SURGICAL STERILIZATION;;STERILIZATION (FEMALE)
+12 ;;PARTNER STERILIZED;;STERILIZATION (MALE)
+13 ;;NONE;;NONE
+14 ;;
SETTOM1 ;
+1 ;create multiple from fields 3, 3.05, 3.1 if it doesn't currently exist
+2 ;edit the multiple .04 if it does exist
+3 ;if 3 field null do nothing
+4 ;
+5 NEW APCDFPV,APCDFPBD,APCDFPDT,APCDTE,APCDT,APCDCOM,APCDISNG,APCDX
+6 SET APCDCOM=""
SET APCDISNG=1
+7 SET APCDFPV=$$VAL^XBDIQ1(9000017,APCDDA1,3)
+8 ;do nothing
IF APCDFPV=""
QUIT
+9 SET APCDFPBD=$PIECE(^AUPNREP(APCDDA1,0),U,7)
+10 SET APCDFPDT=$PIECE(^AUPNREP(APCDDA1,0),U,8)
+11 ;do we have this one on this begun date? if so update .04 and quit
+12 ;get external new value
SET APCDTE=$$NEWVAL(APCDFPV)
+13 ;no external value
IF $PIECE(APCDTE,U,1)=""
QUIT
+14 SET APCDT=$ORDER(^AUTTCM("B",$PIECE(APCDTE,U,1),0))
+15 IF APCDT=""
QUIT
+16 ;already has this one in the multiple
IF APCDFPBD
IF $DATA(^AUPNREP("ACON",APCDDA1,APCDT,APCDFPBD))
SET APCDX=$ORDER(^AUPNREP("ACON",APCDDA1,APCDT,APCDFPBD,APCDDA1,0))
IF APCDX
IF $PIECE(^AUPNREP(APCDDA1,2101,APCDX,0),U,6)=APCDFPV
QUIT
+17 ;already have it with no date
IF 'APCDFPBD
IF $$HASND(APCDDA1,APCDT,APCDFPV)
QUIT
+18 IF $PIECE(APCDTE,U,2)
SET APCDCOM=APCDFPV
+19 ;now create multiple entry
+20 SET DIC="^AUPNREP("_APCDDA1_",2101,"
+21 SET DIC(0)="L"
+22 SET DA(1)=APCDDA1
+23 SET DIC("P")=$PIECE(^DD(9000017,2101,0),U,2)
+24 SET X=APCDT
+25 ;.04///^S X=$S($G(APCDDATE):$$FMTE^XLFDT(APCDDATE),1:$$FMTE^XLFDT(DT))"
SET DIC("DR")=".02////"_APCDFPBD_";.06///"_APCDCOM
+26 KILL DD,D0,DO
+27 DO FILE^DICN
+28 KILL DIC,DD,DO,D0,DA
+29 QUIT
HASND(X,T,C) ;DOES THIS PATIENT HAVE THIS ONE WITH NO DATE BEGUN?
+1 NEW Y,G
+2 SET G=0
+3 SET Y=0
FOR
SET Y=$ORDER(^AUPNREP(X,2101,Y))
IF Y'=+Y
QUIT
IF $PIECE(^AUPNREP(X,2101,Y,0),U,1)=T
IF $PIECE(^AUPNREP(X,2101,Y,0),U,2)=""
IF $PIECE(^AUPNREP(X,2101,Y,0),U,6)=C
SET G=1
+4 QUIT G
+5 ;
MULTOSET ;EP - CALLED FROM TRIGGER
+1 ;if enter into the multiple then overlay 3, 3.05, 3.1 if date begun later than 3.05
+2 ;
+3 NEW APCDDA,APCDDA1
+4 ;MULTIPLE IEN
SET APCDDA=$GET(DA)
+5 ;IEN
SET APCDDA1=$GET(DA(1))
+6 IF 'APCDDA1
QUIT
+7 IF 'APCDDA
QUIT
+8 IF '$DATA(^AUPNREP(APCDDA1,0))
QUIT
+9 DO EN^XBNEW("MUTOSET1^APCDRF","APCDDA1;APCDDA")
+10 QUIT
+11 ;
MUTOSET1 ;
+1 NEW APCDFPV,APCDFPBD,APCDFPDT,APCDTE,APCDT,APCDCOM,APCDINMU
+2 SET APCDCOM=""
SET APCDINMU=1
+3 ;GET LATEST OF THE DATE BEGUNS, IF NO DATE BEGUNS THEN USE THE LAST ONE IN, IF NONE, @ FIELDS
+4 NEW APCDCM,APCDX,APCDC,APCDDB,APCDM
+5 SET APCDX=0
FOR
SET APCDX=$ORDER(^AUPNREP(APCDDA1,2101,APCDX))
IF APCDX'=+APCDX
QUIT
Begin DoDot:1
+6 ;DELETED
IF $PIECE($GET(^AUPNREP(APCDDA1,2101,APCDX,1)),U,1)]""
QUIT
+7 SET APCDC=$PIECE(^AUPNREP(APCDDA1,2101,APCDX,0),U,1)
+8 IF 'APCDC
QUIT
+9 SET APCDDB=$PIECE(^AUPNREP(APCDDA1,2101,APCDX,0),U,2)
+10 SET APCDDE=$PIECE(^AUPNREP(APCDDA1,2101,APCDX,0),U,3)
+11 SET APCDCM((9999999-APCDDB),-APCDX)=""
+12 QUIT
End DoDot:1
+13 SET APCDFPBD=$ORDER(APCDCM(""))
+14 IF 'APCDFPBD
SET DIE="^AUPNREP("
SET DA=APCDDA1
SET DR="3///@;3.05////@;3.1////"_DT
DO ^DIE
KILL DIE,DA,DR
QUIT
+15 SET APCDX=$ORDER(APCDCM(APCDFPBD,""))
+16 IF APCDX=""
QUIT
+17 SET APCDX=$PIECE(APCDX,"-",2)
+18 SET APCDFPV=$PIECE(^AUPNREP(APCDDA1,2101,APCDX,0),U,1)
+19 ;do nothing
IF APCDFPV=""
QUIT
+20 ;BEGUN
SET APCDFPBD=$PIECE(^AUPNREP(APCDDA1,2101,APCDX,0),U,2)
+21 ;UPDATED
SET APCDFPDT=$PIECE(^AUPNREP(APCDDA1,2101,APCDX,0),U,4)
+22 ;do we have this one on this begun date? if so update .04 and quit
+23 ;get external OLD SET value
SET APCDTE=$PIECE(^AUTTCM(APCDFPV,0),U,4)
+24 ;already have that method so edit date begun and date hx obtained
IF $$VAL^XBDIQ1(9000017,APCDDA1,3)=APCDTE
Begin DoDot:1
+25 SET DIE="^AUPNREP("
SET DA=APCDDA1
SET DR="3.05////"_APCDFPBD_";3.1////"_DT
DO ^DIE
KILL DA,DR,DIE
End DoDot:1
QUIT
+26 ;already have one with a greater date begun
IF APCDFPBD
IF $PIECE(^AUPNREP(APCDDA1,0),U,7)'<APCDFPBD
QUIT
+27 SET DIE="^AUPNREP("
SET DA=APCDDA1
SET DR="3///"_APCDTE_";3.05////"_APCDFPBD_";3.1////"_DT
DO ^DIE
KILL DIE,DA,DR
+28 QUIT
EDCTONEW ;EP
+1 IF $GET(APCDEDDI)
QUIT
+2 IF $GET(APCDDEFI)
QUIT
+3 NEW APCDDA1
+4 ;D0
SET APCDDA1=$GET(D0)
+5 IF 'APCDDA1
QUIT
+6 IF '$DATA(^AUPNREP(APCDDA1,0))
QUIT
+7 DO EN^XBNEW("EDCTONE1^APCDRF","APCDDA1")
+8 QUIT
EDCTONE1 ;EP
+1 NEW APCDIEDC
+2 SET APCDIEDC=1
+3 SET APCDEDD=$PIECE(^AUPNREP(APCDDA1,0),U,9)
+4 SET APCDHOW=$PIECE(^AUPNREP(APCDDA1,0),U,10)
+5 IF APCDHOW=""!(APCDHOW=0)
Begin DoDot:1
+6 SET DA=APCDDA1
SET DIE="^AUPNREP("
SET DR="1314///"_APCDEDD
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
QUIT
+7 IF APCDHOW=1
Begin DoDot:1
+8 SET DA=APCDDA1
SET DIE="^AUPNREP("
SET DR="1305////"_APCDEDD_";1314///@"
DO ^DIE
KILL DIE,DA,DR
End DoDot:1
QUIT
+9 IF APCDHOW=2
Begin DoDot:1
+10 SET DA=APCDDA1
SET DIE="^AUPNREP("
SET DR="1302////"_APCDEDD_";1314///@"
DO ^DIE
KILL DIE,DA,DR
End DoDot:1
QUIT
+11 IF APCDHOW=3
Begin DoDot:1
+12 SET DA=APCDDA1
SET DIE="^AUPNREP("
SET DR="1308////"_APCDEDD_";1314///@"
DO ^DIE
KILL DIE,DA,DR
End DoDot:1
QUIT
+13 QUIT
EDDTOEDC(APCDF) ;EP - if enter EDD move to old EDC fields 4, 4.05, 4.1
+1 IF $GET(APCDIEDC)
QUIT
+2 NEW APCDEDDI
+3 SET APCDEDDI=1
+4 NEW APCDDA1
+5 ;D0
SET APCDDA1=$GET(D0)
+6 IF 'APCDDA1
QUIT
+7 IF '$DATA(^AUPNREP(APCDDA1,0))
QUIT
+8 DO EN^XBNEW("EDDTOED1^APCDRF","APCDDA1;APCDF;APCDEDDI")
+9 QUIT
EDDTOED1 ;
+1 NEW APCDHOW
+2 SET APCDHOW=$SELECT(APCDF=1314:0,APCDF=1305:1,APCDF=1302:2,APCDF=1308:3,1:"")
+3 IF APCDHOW=""
QUIT
+4 SET DA=APCDDA1
SET DIE="^AUPNREP("
SET DR="4////"_$$VALI^XBDIQ1(9000017,APCDDA1,APCDF)_";4.05////"_APCDHOW_";4.1////"_$$NOW^XLFDT
DO ^DIE
KILL DIE,DA,DR
+5 QUIT
DEDD ;
+1 IF X="L"
IF $$VAL^XBDIQ1(9000017,DA,1302)=""
Begin DoDot:1
+2 DO EN^DDIOL("EDD (LMP) is blank therefore the Definitive EDD cannot be L - EDD (LMP).")
+3 KILL X
End DoDot:1
QUIT
+4 IF X="U"
IF $$VAL^XBDIQ1(9000017,DA,1305)=""
Begin DoDot:1
+5 DO EN^DDIOL("EDD (ULTRASOUND) is blank therefore the Definitive EDD cannot be U - EDD (ULTRASOUND).")
+6 KILL X
End DoDot:1
QUIT
+7 IF X="C"
IF $$VAL^XBDIQ1(9000017,DA,1308)=""
Begin DoDot:1
+8 DO EN^DDIOL("EDD (CLINICAL PARAMETERS) is blank therefore the Definitive EDD cannot be C - EDD (CLINICAL PARAMETERS).")
+9 KILL X
End DoDot:1
QUIT
+10 QUIT
DEFEDDF4 ;EP - move definitive EDD to EDC 4, 4.05, 4.1
+1 IF $GET(APCDIEDC)
QUIT
+2 NEW APCDDA1
+3 ;D0
SET APCDDA1=$GET(D0)
+4 IF 'APCDDA1
QUIT
+5 IF '$DATA(^AUPNREP(APCDDA1,0))
QUIT
+6 DO EN^XBNEW("DEFEDDF^APCDRF","APCDDA1;APCDF")
+7 QUIT
DEFEDDF ;
+1 NEW APCDHOW,APCDF,APCDDEFI
+2 SET APCDDEFI=1
+3 SET APCDF=$$VALI^XBDIQ1(9000017,APCDDA1,1311)
+4 SET APCDF=$SELECT(APCDF="L":1302,APCDF="U":1305,APCDF="C":1308,1:"")
+5 IF APCDF=""
SET DA=APCDDA1
SET DIE="^AUPNREP("
SET DR="4///@;4.05///@;4.1///@"
DO ^DIE
KILL DIE,DA,DR
QUIT
+6 SET APCDHOW=$SELECT(APCDF=1314:0,APCDF=1305:1,APCDF=1302:2,APCDF=1308:3,1:"")
+7 IF APCDHOW=""
QUIT
+8 SET DA=APCDDA1
SET DIE="^AUPNREP("
SET DR="4////"_$$VALI^XBDIQ1(9000017,APCDDA1,APCDF)_";4.05////"_APCDHOW_";4.1////"_$$NOW^XLFDT
DO ^DIE
KILL DIE,DA,DR
+9 QUIT
