Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCDRF

APCDRF.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;
  1.  ;
  1. RFADD(P) ;PEP - called to add a patient to the Reproductive Factors file
  1.  ;output:  DFN (ien of entry, file is dinum)
  1.  ;         0^error message if add failed
  1.  I '$G(P) Q 0_"^patient DFN invalid"
  1.  I '$D(^DPT(P)) Q 0_"^patient DFN invalid"
  1.  I $P(^DPT(P,0),U,2)'="F" Q 0_"^patient not FEMALE"
  1.  I $D(^AUPNREP(P,0)) Q P
  1.  NEW X,DIC,DD,D0,DO,Y
  1.  S X=P,DIC="^AUPNREP(",DIC(0)="L"
  1.  K DD,D0,DO,DINUM
  1.  S DINUM=X
  1.  D FILE^DICN
  1.  I Y=-1 Q 0_"^fileman failed adding patient"
  1.  Q 1
  1.  ;
  1. RHEDIT(APCDIE,APCDPT,APCDDATA,RETVAL) ;PEP - called to edit reproductive hx data fields
  1.  ;input - APCDPT is DFN of patient
  1.  ;        APCDDATA - passed in by reference array containing fields and values to be updated and put in the FDA array.
  1.  ;                  should be in format APCDDATA(field #)=value (either internal or external)
  1.  ;        either internal or external values can be passed, values will be checked for validity
  1.  ;        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
  1.  ;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
  1.  ;         if patient could not be added to the file the return value will be 0^error message
  1.  ;note:  each individual field value passed is checked for validity, those that pass will be filed, those that don't will be passed back
  1.  ;with the VAL^DIE message
  1.  I '$G(APCDPT) S RETVAL="0^patient DFN invalid" Q
  1.  I '$D(^DPT(APCDPT)) S RETVAL="0^patient DFN invalid" Q
  1.  I $P(^DPT(APCDPT,0),"^",2)'="F" S RETVAL="0^patient not FEMALE" Q
  1.  I $G(APCDVAL)="" S APCDVAL="I"
  1.  I $G(APCDIE)="" S APCDIE="I"  ;default to internal values if not passed in
  1.  NEW V,APCDIENS,APCDFDA,E,APCDC
  1.  S APCDC=0
  1.  I '$D(^AUPNREP(APCDPT,0)) S V=$$RFADD(APCDPT) I 'V S RETVAL=V Q
  1.  ;I $G(APCDDATA)="" S RETVAL="0^no fields to edit" Q  ;Q APCDPT  ;no fields to edit??
  1.  I '$D(APCDDATA) S RETVAL="0^no fields to edit" Q  ;Q APCDPT  ;no fields to edit??
  1.  ;M APCDDATA=@APCDDATA
  1.  I '$O(APCDDATA("")) S RETVAL="0^no fields in the data array" Q  ;Q APCDPT  ;no fields in the data array
  1.  S APCDIENS=APCDPT_","
  1.  S APCDIENS(1)=APCDPT
  1.  ;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
  1.  ;guess you never know what people will try to pass
  1.  NEW APCDF,APCDV,APCDE,APCDI
  1.  I $G(APCDIE)="E" D  ;if external check the validity of data
  1.  .S APCDF="" F  S APCDF=$O(APCDDATA(APCDF)) Q:APCDF=""  D
  1.  ..I APCDF=".01" K APCDDATA(APCDF) Q  ;you can't edit the .01, it's dinum'ed
  1.  ..I '$D(^DD(9000017,APCDF,0)) K APCDDATA(APCDF) D E("field number not valid") Q
  1.  ..S APCDV=APCDDATA(APCDF)
  1.  ..Q:APCDV=""
  1.  ..K APCDE,APCDI
  1.  ..S APCDI=""
  1.  ..D VAL^DIE(9000017,APCDIENS,APCDF,"E",APCDV,.APCDI,,"APCDE")
  1.  ..I $D(APCDE("DIERR",1,"TEXT",1)) D E(APCDE("DIERR",1,"TEXT",1)) K APCDDATA(APCDF) Q
  1.  ..S APCDDATA(APCDF)=APCDI
  1.  ;now set FDA array with values left that are valid and call FILE^DIE
  1.  K APCDFDA
  1.  S APCDF="" F  S APCDF=$O(APCDDATA(APCDF)) Q:APCDF=""  D
  1.  .S APCDFDA(9000017,APCDIENS,APCDF)=APCDDATA(APCDF)
  1.  ;CALL FILE^DIE
  1.  K APCDE
  1.  D FILE^DIE("K","APCDFDA","APCDE(0)")
  1.  S APCDI=0 F  S APCDI=$O(APCDE(0,"DIERR",APCDI)) Q:APCDI'=+APCDI  D
  1.  .Q:'$D(APCDE(0,"DIERR",APCDI,"TEXT"))
  1.  .D E(APCDE(0,"DIERR",APCDI,"TEXT"))
  1.  S RETVAL=APCDPT_"^"_RETVAL
  1.  Q
  1. E(V) ;
  1.  S APCDC=APCDC+1,$P(RETVAL,"|",APCDC)=V
  1.  Q
  1.  ;
  1. TEST ;
  1.  S P=478
  1.  K APCDLORI,LORIERR
  1.  S APCDLORI(2)=3090101
  1.  S APCDLORI(1103)="A"
  1.  ;S APCDLORI(3)="O"
  1.  S APCDLORI(3.05)=3090101
  1.  S APCDLORI(4)=3100405
  1.  S APCDLORI(4.05)="D"
  1.  S APCDLORI(1103)=5
  1.  S APCDLORI(1105)=0
  1.  S APCDLORI(1107)=5
  1.  S APCDLORI(1109)=0
  1.  S APCDLORI(1111)=""
  1.  S APCDLORI(1113)=5
  1.  S APCDLORI(1131)="XX"
  1.  S APCDLORI(1133)=""
  1.  D RHEDIT("E",P,.APCDLORI,.LORIERR)
  1.  ;ZW LORIERR
  1.  Q
  1.  ;
  1. PAUSE ;EP
  1.  S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  Q
  1. OLDCM(%) ;EP - called from trigger
  1.  Q ""
  1. SETTOMUL ;EP - called from trigger on 3 field
  1.  NEW APCDDA,APCDDA1
  1.  S APCDDA1=$G(D0) ;D0
  1.  Q:'APCDDA1
  1.  Q:'$D(^AUPNREP(APCDDA1,0))
  1.  D EN^XBNEW("SETTOM1^APCDRF","APCDDA1")
  1.  Q
  1.  ;
  1. NEWVAL(E) ;
  1.  NEW X,Y,APCDTEXT,APCDY
  1.  S Y=""
  1.  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)
  1.  Q Y
  1.  ;
  1. CMMAP ;;
  1.  ;;ABSTINENCE;;ABSTINENCE
  1.  ;;HORMONE INJECTION;;HORMONAL/DEPO PROVERA
  1.  ;;HORMONAL IMPLANT;;HORMONAL/IMPLANT
  1.  ;;MENOPAUSE;;NA MENOPAUSE
  1.  ;;EDUCATION ONLY;;OTHER;;1
  1.  ;;ORAL CONTRACEPTIVES;;OTHER;;1
  1.  ;;IUD;;OTHER;;1
  1.  ;;BARRIER METHODS;;OTHER;;1
  1.  ;;OTHER;;OTHER
  1.  ;;NATURAL TECHNIQUES;;PERIODIC ABSTINENCE METHODS
  1.  ;;SURGICAL STERILIZATION;;STERILIZATION (FEMALE)
  1.  ;;PARTNER STERILIZED;;STERILIZATION (MALE)
  1.  ;;NONE;;NONE
  1.  ;;
  1. SETTOM1 ;
  1.  ;create multiple from fields 3, 3.05, 3.1 if it doesn't currently exist
  1.  ;edit the multiple .04 if it does exist
  1.  ;if 3 field null do nothing
  1.  ;
  1.  NEW APCDFPV,APCDFPBD,APCDFPDT,APCDTE,APCDT,APCDCOM,APCDISNG,APCDX
  1.  S APCDCOM="",APCDISNG=1
  1.  S APCDFPV=$$VAL^XBDIQ1(9000017,APCDDA1,3)
  1.  I APCDFPV="" Q  ;do nothing
  1.  S APCDFPBD=$P(^AUPNREP(APCDDA1,0),U,7)
  1.  S APCDFPDT=$P(^AUPNREP(APCDDA1,0),U,8)
  1.  ;do we have this one on this begun date?  if so update .04 and quit
  1.  S APCDTE=$$NEWVAL(APCDFPV)  ;get external new value
  1.  I $P(APCDTE,U,1)="" Q  ;no external value
  1.  S APCDT=$O(^AUTTCM("B",$P(APCDTE,U,1),0))
  1.  I APCDT="" Q
  1.  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
  1.  I 'APCDFPBD Q:$$HASND(APCDDA1,APCDT,APCDFPV)  ;already have it with no date
  1.  I $P(APCDTE,U,2) S APCDCOM=APCDFPV
  1.  ;now create multiple entry
  1.  S DIC="^AUPNREP("_APCDDA1_",2101,"
  1.  S DIC(0)="L"
  1.  S DA(1)=APCDDA1
  1.  S DIC("P")=$P(^DD(9000017,2101,0),U,2)
  1.  S X=APCDT
  1.  S DIC("DR")=".02////"_APCDFPBD_";.06///"_APCDCOM   ;.04///^S X=$S($G(APCDDATE):$$FMTE^XLFDT(APCDDATE),1:$$FMTE^XLFDT(DT))"
  1.  K DD,D0,DO
  1.  D FILE^DICN
  1.  K DIC,DD,DO,D0,DA
  1.  Q
  1. HASND(X,T,C) ;DOES THIS PATIENT HAVE THIS ONE WITH NO DATE BEGUN?
  1.  NEW Y,G
  1.  S G=0
  1.  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
  1.  Q G
  1.  ;
  1. 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
  1.  ;
  1.  NEW APCDDA,APCDDA1
  1.  S APCDDA=$G(DA)  ;MULTIPLE IEN
  1.  S APCDDA1=$G(DA(1)) ;IEN
  1.  Q:'APCDDA1
  1.  Q:'APCDDA
  1.  Q:'$D(^AUPNREP(APCDDA1,0))
  1.  D EN^XBNEW("MUTOSET1^APCDRF","APCDDA1;APCDDA")
  1.  Q
  1.  ;
  1. MUTOSET1 ;
  1.  NEW APCDFPV,APCDFPBD,APCDFPDT,APCDTE,APCDT,APCDCOM,APCDINMU
  1.  S APCDCOM="",APCDINMU=1
  1.  ;GET LATEST OF THE DATE BEGUNS, IF NO DATE BEGUNS THEN USE THE LAST ONE IN, IF NONE, @ FIELDS
  1.  NEW APCDCM,APCDX,APCDC,APCDDB,APCDM
  1.  S APCDX=0 F  S APCDX=$O(^AUPNREP(APCDDA1,2101,APCDX)) Q:APCDX'=+APCDX  D
  1.  .Q:$P($G(^AUPNREP(APCDDA1,2101,APCDX,1)),U,1)]""  ;DELETED
  1.  .S APCDC=$P(^AUPNREP(APCDDA1,2101,APCDX,0),U,1)
  1.  .Q:'APCDC
  1.  .S APCDDB=$P(^AUPNREP(APCDDA1,2101,APCDX,0),U,2)
  1.  .S APCDDE=$P(^AUPNREP(APCDDA1,2101,APCDX,0),U,3)
  1.  .S APCDCM((9999999-APCDDB),-APCDX)=""
  1.  .Q
  1.  S APCDFPBD=$O(APCDCM(""))
  1.  I 'APCDFPBD S DIE="^AUPNREP(",DA=APCDDA1,DR="3///@;3.05////@;3.1////"_DT D ^DIE K DIE,DA,DR Q
  1.  S APCDX=$O(APCDCM(APCDFPBD,""))
  1.  Q:APCDX=""
  1.  S APCDX=$P(APCDX,"-",2)
  1.  S APCDFPV=$P(^AUPNREP(APCDDA1,2101,APCDX,0),U,1)
  1.  I APCDFPV="" Q  ;do nothing
  1.  S APCDFPBD=$P(^AUPNREP(APCDDA1,2101,APCDX,0),U,2)  ;BEGUN
  1.  S APCDFPDT=$P(^AUPNREP(APCDDA1,2101,APCDX,0),U,4)  ;UPDATED
  1.  ;do we have this one on this begun date?  if so update .04 and quit
  1.  S APCDTE=$P(^AUTTCM(APCDFPV,0),U,4)  ;get external OLD SET value
  1.  I $$VAL^XBDIQ1(9000017,APCDDA1,3)=APCDTE D  Q  ;already have that method so edit date begun and date hx obtained
  1.  .S DIE="^AUPNREP(",DA=APCDDA1,DR="3.05////"_APCDFPBD_";3.1////"_DT D ^DIE K DA,DR,DIE
  1.  I APCDFPBD Q:$P(^AUPNREP(APCDDA1,0),U,7)'<APCDFPBD  ;already have one with a greater date begun
  1.  S DIE="^AUPNREP(",DA=APCDDA1,DR="3///"_APCDTE_";3.05////"_APCDFPBD_";3.1////"_DT D ^DIE K DIE,DA,DR
  1.  Q
  1. EDCTONEW ;EP
  1.  Q:$G(APCDEDDI)
  1.  Q:$G(APCDDEFI)
  1.  NEW APCDDA1
  1.  S APCDDA1=$G(D0) ;D0
  1.  Q:'APCDDA1
  1.  Q:'$D(^AUPNREP(APCDDA1,0))
  1.  D EN^XBNEW("EDCTONE1^APCDRF","APCDDA1")
  1.  Q
  1. EDCTONE1 ;EP
  1.  NEW APCDIEDC
  1.  S APCDIEDC=1
  1.  S APCDEDD=$P(^AUPNREP(APCDDA1,0),U,9)
  1.  S APCDHOW=$P(^AUPNREP(APCDDA1,0),U,10)
  1.  I APCDHOW=""!(APCDHOW=0) D  Q
  1.  .S DA=APCDDA1,DIE="^AUPNREP(",DR="1314///"_APCDEDD D ^DIE K DA,DIE,DR
  1.  I APCDHOW=1 D  Q
  1.  .S DA=APCDDA1,DIE="^AUPNREP(",DR="1305////"_APCDEDD_";1314///@" D ^DIE K DIE,DA,DR
  1.  I APCDHOW=2 D  Q
  1.  .S DA=APCDDA1,DIE="^AUPNREP(",DR="1302////"_APCDEDD_";1314///@" D ^DIE K DIE,DA,DR
  1.  I APCDHOW=3 D  Q
  1.  .S DA=APCDDA1,DIE="^AUPNREP(",DR="1308////"_APCDEDD_";1314///@" D ^DIE K DIE,DA,DR
  1.  Q
  1. EDDTOEDC(APCDF) ;EP - if enter EDD move to old EDC fields 4, 4.05, 4.1
  1.  I $G(APCDIEDC) Q
  1.  NEW APCDEDDI
  1.  S APCDEDDI=1
  1.  NEW APCDDA1
  1.  S APCDDA1=$G(D0) ;D0
  1.  Q:'APCDDA1
  1.  Q:'$D(^AUPNREP(APCDDA1,0))
  1.  D EN^XBNEW("EDDTOED1^APCDRF","APCDDA1;APCDF;APCDEDDI")
  1.  Q
  1. EDDTOED1 ;
  1.  NEW APCDHOW
  1.  S APCDHOW=$S(APCDF=1314:0,APCDF=1305:1,APCDF=1302:2,APCDF=1308:3,1:"")
  1.  I APCDHOW="" Q
  1.  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
  1.  Q
  1. DEDD ;
  1.  I X="L",$$VAL^XBDIQ1(9000017,DA,1302)="" D  Q
  1.  .D EN^DDIOL("EDD (LMP) is blank therefore the Definitive EDD cannot be L - EDD (LMP).")
  1.  .K X
  1.  I X="U",$$VAL^XBDIQ1(9000017,DA,1305)="" D  Q
  1.  .D EN^DDIOL("EDD (ULTRASOUND) is blank therefore the Definitive EDD cannot be U - EDD (ULTRASOUND).")
  1.  .K X
  1.  I X="C",$$VAL^XBDIQ1(9000017,DA,1308)="" D  Q
  1.  .D EN^DDIOL("EDD (CLINICAL PARAMETERS) is blank therefore the Definitive EDD cannot be C - EDD (CLINICAL PARAMETERS).")
  1.  .K X
  1.  Q
  1. DEFEDDF4 ;EP - move definitive EDD to EDC 4, 4.05, 4.1
  1.  I $G(APCDIEDC) Q
  1.  NEW APCDDA1
  1.  S APCDDA1=$G(D0) ;D0
  1.  Q:'APCDDA1
  1.  Q:'$D(^AUPNREP(APCDDA1,0))
  1.  D EN^XBNEW("DEFEDDF^APCDRF","APCDDA1;APCDF")
  1.  Q
  1. DEFEDDF ;
  1.  NEW APCDHOW,APCDF,APCDDEFI
  1.  S APCDDEFI=1
  1.  S APCDF=$$VALI^XBDIQ1(9000017,APCDDA1,1311)
  1.  S APCDF=$S(APCDF="L":1302,APCDF="U":1305,APCDF="C":1308,1:"")
  1.  I APCDF="" S DA=APCDDA1,DIE="^AUPNREP(",DR="4///@;4.05///@;4.1///@" D ^DIE K DIE,DA,DR Q
  1.  S APCDHOW=$S(APCDF=1314:0,APCDF=1305:1,APCDF=1302:2,APCDF=1308:3,1:"")
  1.  I APCDHOW="" Q
  1.  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
  1.  Q