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

APCDAUTL.m

Go to the documentation of this file. 
  1. APCDAUTL ; IHS/CMI/LAB - misc calls from pcc data entry templates ;
  1.  ;;2.0;IHS PCC SUITE;**22**;MAY 14, 2009;Build 6
  1.  ;
  1.  ;
  1. ST(PATIENT,DATE,STDA) ;EP - called from APCD ST (ADD) template to find parent entry 
  1.  NEW X,ERR,E,B,S,STIEN,TEST
  1.  S STIEN=""
  1.  ;when reading is entered
  1.  ;set vars for data fetcher, find last skin test placed within
  1.  ;30 days of date of visit, make sure that one does not have
  1.  ;a reading already
  1. ST1 ;
  1.  Q:$G(DATE)=""
  1.  Q:$G(PATIENT)=""
  1.  Q:$G(STDA)=""
  1.  S TEST=$P(^AUPNVSK(STDA,0),U)
  1.  S B=$$FMTE^XLFDT(DATE,"1D")
  1.  S E=$$FMADD^XLFDT(DATE,-30)
  1.  S E=$$FMTE^XLFDT(E,"1D")
  1.  S X=PATIENT_"^SKIN `"_TEST_";DURING "_E_"-"_B
  1.  S ERR=$$START1^APCLDF(X,"S(")
  1.  I ERR!('$D(S))!('$O(S(0))) Q STIEN
  1.  S X=99999999 F  S X=$O(S(X),-1) Q:X=""!(STIEN)  I +$P(S(X),U,4)'=STDA,$P(^AUPNVSK(+$P(S(X),U,4),0),U,4)="",$P(^(0),U,5)="" S STIEN=+$P(S(X),U,4)
  1.  Q STIEN
  1. GET04 ;EP - called from APCD VDEL (ADD) and APCDVDEL (MOD) templates
  1.  ;display list with reader call
  1.  ;get subset
  1.  D EN^XBNEW("GET040^APCDAUTL","APCDTDA;APCDTRET")
  1.  W !
  1.  Q
  1. GET040 ;EP - called from xbnew
  1.  W !!,"LABOR ESTABLISHED SNOMED CONCEPT ID"
  1.  S IN="EHR LABOR ESTABLISHED"
  1.  K LIST
  1.  S X=$$SUBLST^BSTSAPI("LIST",IN)
  1.  ;I '$O(LIST(0)) D SET04LST
  1.  ;
  1. GET041 S S="",APCDTRET=""
  1.  D DISP  ;DISPLAY LIST AND GET VALUE
  1.  I S="" W !,"A SNOMED CONCEPT ID is REQUIRED!" G GET041
  1.  S APCDTRET=S
  1.  Q
  1. DISP ;
  1.  W !!
  1.  S X=0,C=0 F  S X=$O(LIST(X)) Q:X'=+X  S C=C+1 W ?2,X,") ",$P(LIST(X),U,1),?20,$P(LIST(X),U,3),!
  1.  ;now get choice
  1.  S DIR(0)="N^1:"_C_":0",DIR("A")="Please Choose a SNOMED CONCEPT ID from the list above" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) W !,"Choosing a SNOMED is required." G DISP
  1.  S S=$P(LIST(+Y),U,1)
  1.  Q
  1. GET07 ;EP - called from APCD VDEL (ADD) and APCDVDEL (MOD) templates
  1.  ;display list with reader call
  1.  ;get subset
  1.  D EN^XBNEW("GET070^APCDAUTL","APCDTDA;APCDTRET")
  1.  W !
  1.  Q
  1. GET070 ;EP - called from xbnew
  1.  W !!,"LABOR INDUCTION SNOMED CONCEPT ID"
  1.  S IN="EHR LABOR INDUCTION TYPE"
  1.  K LIST
  1.  S X=$$SUBLST^BSTSAPI("LIST",IN)
  1.  ;I '$O(LIST(0)) D SET07LST
  1.  ;
  1. GET071 S S="",APCDTRET=""
  1.  D DISP  ;DISPLAY LIST AND GET VALUE
  1.  I S="" W !,"A SNOMED CONCEPT ID is REQUIRED!" G GET071
  1.  S APCDTRET=S
  1.  Q
  1. SET04LST ;
  1.  S LIST(1)="20236002^^Labor established (finding)"
  1.  S LIST(2)="289211007^^First stage of labor established (finding)"
  1.  S LIST(3)="366325002^^Finding of progress of labor - first stage (finding)"
  1.  S LIST(4)="6383007^^Premature labor (finding)"
  1.  S LIST(5)="6893006^^First stage of labor (finding)"
  1.  S LIST(6)="84457005^^Spontaneous onset of labor (finding)"
  1.  Q
  1. SET07LST ;
  1.  S LIST(1)="177135005^^Oxytocin induction of labor (procedure)"
  1.  S LIST(2)="177136006^^Prostaglandin induction of labor (procedure)"
  1.  S LIST(3)="237002008^^Stimulation of labor (procedure)"
  1.  S LIST(4)="288189000^^Induction of labor by intravenous injection (procedure)"
  1.  S LIST(5)="288190009^^Induction of labor by intravenous drip (procedure)"
  1.  S LIST(6)="308037008^^Syntocinon induction of labor (procedure)"
  1.  S LIST(7)="31208007^^Medical induction of labor (procedure)"
  1.  S LIST(8)="408816000^^Artificial rupture of membranes (procedure)"
  1.  S LIST(9)="408818004^^Induction of labor by artificial rupture of membranes (procedure)"
  1.  Q
  1. NEWBORN ;EP- called from APCD VDEL (ADD) AND APCD VDEL (MOD)
  1.  D EN^XBNEW("NEWBORN1^APCDAUTL","APCDTDA")
  1.  W !
  1.  Q
  1. NEWBORN1 ;
  1.  ;display existing NEWBORN DATA
  1.  W !!?2,"Newborn Data:"
  1.  I '$O(^AUPNVDLV(APCDTDA,11,0)) S APCDC=0 W "  None recorded" G FM12
  1.  D EN^DDIOL($$REPEAT^XLFSTR("-",75),"","!?1")
  1.  K APCDCM S X=0,APCDC=0 F  S X=$O(^AUPNVDLV(APCDTDA,11,X)) Q:X'=+X  D
  1.  .S APCDC=APCDC+1,APCDCM(APCDC)=X
  1.  .W !?2,APCDC,")  ",$$GET1^DIQ(9000010.6411,X_","_APCDTDA,.01),"  ",$$GET1^DIQ(9000010.6411,X_","_APCDTDA,.05),"  ",$$GET1^DIQ(9000010.6411,X_","_APCDTDA,.06)
  1. FM12 ;
  1.  D EN^DDIOL("","","!")
  1.  K DIR
  1.  S DIR(0)="S^A:Add a Newborn Entry"_$S(APCDC:";E:Edit an Existing Newborn Entry;D:Delete a Newborn Entry",1:"")_";N:No Change"
  1.  S DIR("A")="Which action",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT),$O(^AUPNVDLV(APCDTDA,11,0)) G FM13
  1.  I $D(DIRUT),'$O(^AUPNVDLV(APCDTDA,11,0)) W !!,"At least one Newborn entry is required." G NEWBORN1
  1.  I Y="N",$O(^AUPNVDLV(APCDTDA,11,0)) S APCDDONE=1 G FM13
  1.  I Y="N",'$O(^AUPNVDLV(APCDTDA,11,0)) W !!,"At least one Newborn entry is required." G NEWBORN1
  1.  S Y="FM"_Y
  1.  D @Y
  1.  G NEWBORN1
  1. FM13 ; 
  1.  K Y
  1.  Q
  1.  ;
  1. FME ;
  1.  D EN^DDIOL("","","!")
  1.  K DIR
  1.  S DIR(0)="N^1:"_APCDC_":0",DIR("A")="Edit Which One" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) Q
  1. FME1 ;EP
  1.  K DIC,DA,DR
  1.  S APCDTMDA=APCDCM(Y)
  1.  S APCDTEGA=$$EGA(APCDTDA,APCDTMDA)
  1.  I APCDTEGA="" W !!,"Note:  There are no EGA measurements on file between a day before",!,"and the delivery date. You will need to manually enter the EGA.",!
  1.  I APCDTEGA]"" W !!,"NOTE:  EGA was ",$P(APCDTEGA,U,3)," on ",$$FMTE^XLFDT($P(APCDTEGA,U,1))
  1.  S DA=APCDCM(Y),DR=".01;.03//"_APCDTEGA_";.05;.06",DA(1)=APCDTDA
  1.  S DIE="^AUPNVDLV("_APCDTDA_",11,"
  1.  D ^DIE
  1.  F X=1:1:6 I $P(^AUPNVDLV(APCDTDA,11,DA,0),U,X)="" W !,"All data values are required.  Please update." G FME1
  1.  K DIE
  1.  Q
  1. FMD ;
  1.  D EN^DDIOL("","","!")
  1.  K DIR
  1.  S DIR(0)="N^1:"_APCDC_":0",DIR("A")="Delete Which One" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) Q
  1.  K DIC,DA,DR
  1.  S DA=APCDCM(Y),DA(1)=APCDTDA,DIK="^AUPNVDLV("_APCDTDA_",11," D ^DIK K DA,DIK
  1.  Q
  1. FMA ;
  1.  S DIR(0)="D^::ENPRTXS",DIR("A")="Enter NEWBORN Delivery Date/Time" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) Q
  1.  I Y="" Q
  1.  I Y>$$NOW^XLFDT W !!,"Cannot be a date/time in the future." G FMA
  1.  S X=Y
  1.  S DIC(0)="L",DIC="^AUPNVDLV("_APCDTDA_",11,",DA(1)=APCDTDA,DIC("DR")=""  ;
  1.  D FILE^DICN
  1.  S APCDTMDA=+Y
  1.  S APCDTEGA=$$EGA(APCDTDA,APCDTMDA)
  1.  I APCDTEGA="" W !!,"Note:  There are no EGA measurements on file between a day before",!,"and the delivery date. You will need to manually enter the EGA.",!
  1.  I APCDTEGA]"" W !!,"NOTE:  EGA was ",$P(APCDTEGA,U,3)," on ",$$FMTE^XLFDT($P(APCDTEGA,U,1)),!
  1. FMA1 ;
  1.  K DIC,DA,DR
  1.  S DA=APCDTMDA,DR=".03//"_$P(APCDTEGA,U,3)_";.05;.06",DA(1)=APCDTDA
  1.  S DIE="^AUPNVDLV("_APCDTDA_",11,"
  1.  D ^DIE
  1.  F X=1:1:6 I $P(^AUPNVDLV(APCDTDA,11,DA,0),U,X)="" W !,"All data values are required.  Please update." G FMA1
  1.  K DIE
  1.  Q
  1. EGA(APCDI,APCDM) ;
  1.  ;get admission date, delivery date
  1.  NEW DELV,BD,ED
  1.  S DELV=$P($P(^AUPNVDLV(APCDI,11,APCDM,0),U,1),".")
  1.  S BD=$$FMADD^XLFDT(DELV,-1)
  1.  S ED=DELV
  1.  ;get LAST EGA in bd to ed
  1.  S P=$P(^AUPNVDLV(APCDI,0),U,2)
  1.  S C=$$LASTITEM^APCLAPIU(P,"EGA","MEASUREMENT",BD,ED,"A")
  1.  I C="" Q ""
  1.  Q C
  1. GET04E ;EP - called from APCD VDEL (ADD) and APCDVDEL (MOD) templates
  1.  ;display list with reader call
  1.  ;get subset
  1.  D EN^XBNEW("GET040E^APCDAUTL","APCDTDA;APCDTRET")
  1.  W !
  1.  Q
  1. GET040E ;EP - called from xbnew
  1.  W !!,"LABOR ESTABLISHED SNOMED CONCEPT ID"
  1.  S IN="EHR LABOR ESTABLISHED"
  1.  K LIST
  1.  S X=$$SUBLST^BSTSAPI("LIST",IN)
  1.  ;I '$O(LIST(0)) D SET04LST
  1.  ;DISPLAY LIST
  1.  W !!
  1.  S X=0,C=0 F  S X=$O(LIST(X)) Q:X'=+X  S C=C+1 W ?2,X,") ",$P(LIST(X),U,1),?20,$P(LIST(X),U,3),!
  1.  ;I $$VAL^XBDIQ1(9000010.64,APCDTDA,.04)="" G GET041E
  1.  W !,"LABOR ESTABLISHED SNOMED CONCEPT ID: ",$$VAL^XBDIQ1(9000010.64,APCDTDA,.04),!
  1.  S DIR(0)="Y",DIR("A")="Do you wish to change the SNOMED code",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I 'Y S APCDTRET=$$VAL^XBDIQ1(9000010.64,APCDTDA,.04) Q
  1.  I $D(DIRUT) S APCDTRET=$$VAL^XBDIQ1(9000010.64,APCDTDA,.04) Q
  1.  ;
  1. GET041E S S="",APCDTRET=""
  1.  D DISP  ;DISPLAY LIST AND GET VALUE
  1.  I S="" W !,"A SNOMED CONCEPT ID is REQUIRED!" G GET041E
  1.  S APCDTRET=S
  1.  Q
  1. GET07E ;EP - called from APCD VDEL (ADD) and APCDVDEL (MOD) templates
  1.  ;display list with reader call
  1.  ;get subset
  1.  D EN^XBNEW("GET070E^APCDAUTL","APCDTDA;APCDTRET")
  1.  W !
  1.  Q
  1. GET070E ;EP - called from xbnew
  1.  W !!,"LABOR INDUCTION SNOMED CONCEPT ID"
  1.  S IN="EHR LABOR INDUCTION TYPE"
  1.  K LIST
  1.  S X=$$SUBLST^BSTSAPI("LIST",IN)
  1.  ;I '$O(LIST(0)) D SET07LST
  1.  ;DISPLAY LIST
  1.  W !!
  1.  I $$VAL^XBDIQ1(9000010.64,APCDTDA,.07)]"" S X=0,C=0 F  S X=$O(LIST(X)) Q:X'=+X  S C=C+1 W ?2,X,") ",$P(LIST(X),U,1),?20,$P(LIST(X),U,3),!
  1.  I $$VAL^XBDIQ1(9000010.64,APCDTDA,.07)="" G GET071E
  1.  W !,"LABOR INDUCTION SNOMED CONCEPT ID: ",$$VAL^XBDIQ1(9000010.64,APCDTDA,.07),!
  1.  S DIR(0)="Y",DIR("A")="Do you wish to change the SNOMED code",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I 'Y S APCDTRET=$$VAL^XBDIQ1(9000010.64,APCDTDA,.07) Q
  1.  I $D(DIRUT) S APCDTRET=$$VAL^XBDIQ1(9000010.64,APCDTDA,.07) Q
  1.  ;
  1. GET071E S S="",APCDTRET=""
  1.  D DISP  ;DISPLAY LIST AND GET VALUE
  1.  I S="" W !,"A SNOMED CONCEPT ID is REQUIRED!" G GET071E
  1.  S APCDTRET=S
  1.  Q
  1. GLDT ;EP - called from input template
  1.  D EN^XBNEW("GLDT1^APCDAUTL","APCDTDA;APCDTDDT")
  1.  W !
  1.  Q
  1. GLDT1 ;
  1.  S APCDTDDT=""
  1.  S DIR(0)="DO^::ENPRTXS",DIR("A")="Labor Established (Date/Time)",DIR("?")="Response must be a date/time, cannot be a date/time in the future." KILL DA D ^DIR
  1.  KILL DIR
  1.  I $D(DIRUT) Q
  1.  I Y>$$NOW^XLFDT W !!,"Response must be a date/time, cannot be a date/time in the future." G GLDT1
  1.  S APCDTDDT=Y
  1.  Q