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

APCDAALG.m

Go to the documentation of this file. 
  1. APCDAALG ; IHS/CMI/LAB - ALLERGY ENTRY INTO ALLERGY PACKAGE ;
  1.  ;;2.0;IHS PCC SUITE;**5**;MAY 14, 2009
  1.  ;
  1.  ;
  1. EP ;
  1.  I '$D(^XUSEC("GMRA-USER",DUZ)) W !!,"You have not been assigned the Allergy Tracking user key.",!,"Please see your supervisor.",! Q
  1.  I $T(EN21^GMRAPEM0)="" W !!,"The Allergy tracking system has not been installed.",!,"Enter allergies through the problem list.",! Q
  1.  S DFN=APCDPAT
  1.  D EN^XBNEW("EP1^APCDAALG","DFN")
  1.  I '$G(DFN) S DFN=APCDPAT
  1.  D ALUDE
  1.  Q
  1. EP1 ;
  1.  D EN21^GMRAPEM0
  1.  D EN^XBVK("GMRA"),EN^XBVK("VA")
  1.  Q
  1. ANYACTA(APCDSDFN,EDATE) ;
  1.  I $G(EDATE)="" S EDATE=DT
  1.  NEW G,APCDNKAI,X,H,D
  1.  I '$D(^GMR(120.8,"B",APCDSDFN)) Q 0
  1.  I $O(^GMR(120.8,"ANKA",APCDSDFN,""))="n" I $O(^GMR(120.8,"ANKA",APCDSDFN,"n","")) Q 0
  1.  S X="",G=0 F  S X=$O(^GMR(120.8,"B",APCDSDFN,X)) Q:(X="")!(G)  D
  1.  .Q:$$TEST(X)
  1.  .S H=$G(^GMR(120.8,X,0))
  1.  .Q:'H
  1.  .Q:$P(H,U,22)]""  ;DONT WANT IN EITHER CASE-N SHOULD ALREADY BE TAKEN CARE OF IN XREF AND NOT GET HERE AND IF Y NEED TO LOOK ELSEWHERE IHS/OKCAO/POC 5/25/2001
  1.  .S D=$P($P(H,U,4),".",1)
  1.  .Q:D=""
  1.  .S G=1
  1.  Q G
  1. TEST(CHECKIT) ;CHECK IF VERIFED AND NOT ENTERED IN ERROR
  1.  N CHECK
  1.  S CHECK=0 ;CHECK=1 ENTERED IN ERROR OR NOT VERIFED
  1.  ;S:$D(^GMR(120.8,CHECKIT,"ER")) CHECK=1
  1.  S:$P($G(^GMR(120.8,CHECKIT,"ER")),U)=1 CHECK=1  ;CMI/GRL  *17*
  1.  Q CHECK
  1. ALUDE ;EP
  1.  ;get provider who updated and date
  1.  ;NEW APCDPRBI
  1.  ;S APCDPRBI=DA
  1.  S APCDP=$G(APCDPAT)
  1.  I 'APCDP S APCDP=$G(DFN)
  1.  S APCDV=$G(APCDVSIT)
  1.  S APCDD=$G(APCDDATE)
  1.  ;
  1.  D EN^XBNEW("ALUDE1^APCDAALG","APCDP;APCDV;APCDD;APCDPRBI")
  1.  Q
  1. ALUDE1 ;EP - called from xbnew
  1.  ;get date pl updated
  1.  W !!
  1.  K DIR
  1.  S DIR(0)="Y",DIR("A")="Was the Allergy List Updated",DIR("B")="Y" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) Q
  1.  I 'Y Q
  1.  S DIR(0)="D^::EPTSX",DIR("A")="Enter the Date the Allergy List was Updated by the Provider"
  1.  S DIR("B")=$S($G(APCDD):$$FMTE^XLFDT($P(APCDD,".")),$G(APCDV):$$FMTE^XLFDT($$VD^APCLV(APCDV)),1:$$FMTE^XLFDT(DT)),DIR("?")="This is the visit date or the date the provider updated the Allergy list."
  1.  KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) W !!,"This is required." G ALUDE1
  1.  I $P(Y,".")>DT W !!,"Future Dates now allowed.",! G ALUDE1
  1.  S APCDD=Y
  1. ALUDE1P ;GET PROVIDER
  1.  S DIR(0)="9000010.54,1204",DIR("A")="Enter the PROVIDER who Updated the Allergy List"
  1.  S DIR("B")=$S($G(APCDV):$$PRIMPROV^APCLV(APCDV,"N"),1:"") KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) W !!,"This is required."  G ALUDE1P
  1.  S APCDPRV=+Y
  1.  D ALU($G(APCDPRBI),APCDV,APCDP,APCDD,APCDPRV,.APCDRET)
  1.  I $P(APCDRET,U,1)=0 W !!,"error:  ",$P(APCDRET,U,2)
  1.  Q
  1. ALU(APCDPIEN,APCDV,APCDP,APCDD,APCDPRV,RETVAL) ;PEP - called to update Allergy update fields
  1.  ;this API can be called to have a V UPDATED/REVIEWED entry and populate the
  1.  ;.11, .12, and .13 fields
  1.  ;input:  APCDPIEN - ien of Allergy entry
  1.  ;        APCDV - ien of visit, if in the context of a visit
  1.  ;        APCDP - DFN
  1.  ;        APCDD - Date and optionally time of Allergy list update (fileman format)
  1.  ;        APCDPRV = ien of provider updating the Allergy list
  1.  ;this API will create a new V UPDATED/REVIEWED entry if there isn't currently one
  1.  ;for Provider APCDP on date APCDD
  1.  ;if not in the context of a visit (APCDV = null) then an event visit will be created
  1.  ;with a V UPDATED/REVIEWED v file entry
  1.  ;
  1.  ;RETURN VALUE:
  1.  ;            ien of V UPDATED/REVIEWED entry that was created
  1.  ;             or 0^error message
  1.  S APCDPIEN=$G(APCDPIEN)
  1.  S APCDV=$G(APCDV)
  1.  S APCDP=$G(APCDP)
  1.  I 'APCDP S RETVAL="0^not a valid patient DFN" Q
  1.  I '$D(^AUPNPAT(APCDP,0)) S RETVAL="0^not a valid patient DFN" Q
  1.  S APCDD=$G(APCDD)
  1.  I 'APCDD S RETVAL="0^no valid date passed" Q
  1.  S APCDPRV=$G(APCDPRV)
  1.  I 'APCDPRV S RETVAL="0^no valid provider ien passed" Q
  1.  S RETVAL=""
  1.  ;
  1.  I APCDV D ALUV Q
  1.  ;NO VISIT SO CREATE EVENT VISIT AND CALL ALUV
  1.  D EVSIT
  1.  Q
  1. ALUV ;have a visit so create a v updated/reviewed for provider APCDPRV if one does
  1.  ;not exist on this visit already.
  1.  NEW APCDX,APCDVD,APCDVRI,APCDVAL
  1.  S APCDVAL=$O(^AUTTCRA("C","ALU",0))
  1.  I APCDVAL="" S RETVAL="0^action item missing" Q
  1.  S APCDVRI=""
  1.  S APCDX=0 F  S APCDX=$O(^AUPNVRUP("AD",APCDV,APCDX)) Q:APCDX=""!(APCDVRI)  D
  1.  .;is this entry a Allergy list review entry?
  1.  .Q:$P(^AUPNVRUP(APCDX,0),U,1)'=APCDVAL  ;this one isn't a ALU entry
  1.  .Q:$P($G(^AUPNVRUP(APCDX,2)),U,1)
  1.  .Q:$P($G(^AUPNVRUP(APCDX,12)),U,4)'=APCDPRV  ;not this provider
  1.  .S APCDVRI=APCDX  ;found one so don't create one
  1.  .Q
  1.  I APCDVRI S RETVAL=APCDVRI Q
  1.  ;create V UPDATED/REVIEWED entry
  1.  NEW APCDALVR
  1.  S APCDALVR("APCDPAT")=APCDP
  1.  S APCDALVR("APCDVSIT")=APCDV
  1.  S APCDALVR("APCDATMP")="[APCDALVR 9000010.54 (ADD)]"
  1.  S APCDALVR("APCDTCLA")="`"_APCDVAL
  1.  S APCDALVR("APCDTCDT")=APCDD
  1.  S APCDALVR("APCDTEPR")="`"_APCDPRV
  1.  D ^APCDALVR
  1.  I $D(APCDALVR("APCDAFLG")) S RETVAL=0_"^Error creating V UPDATED/REVIEWED entry.  PCC not updated."
  1.  K APCDALVR
  1.  Q
  1. BSD ;
  1.  NEW APCDBSDV
  1.  K APCDIN
  1.  S APCDIN("PAT")=APCDP
  1.  S APCDIN("VISIT DATE")=APCDD_".12"
  1.  S APCDIN("SITE")=DUZ(2)
  1.  S APCDIN("VISIT TYPE")=$S($P($G(^APCCCTRL(DUZ(2),0)),U,4)]"":$P(^APCCCTRL(DUZ(2),0),U,4),1:"O")
  1.  S APCDIN("SRV CAT")="E"
  1.  S APCDIN("TIME RANGE")=0
  1.  S APCDIN("USR")=DUZ
  1.  K APCDALVR
  1.  K APCDBSDV
  1.  D GETVISIT^APCDAPI4(.APCDIN,.APCDBSDV)
  1.  S T=$P(APCDBSDV(0),U,2)
  1.  I T]"" S RETVAL="0^could not create event visit" Q   ;errored
  1.  S V=$O(APCDBSDV(0)) S APCDV=V
  1.  I $G(APCDBSDV(V))="ADD" D DEDT^APCDEA2(APCDV)
  1.  Q
  1. EVSIT ;EP - get/create event visit
  1.  I $L($T(^BSDAPI4)) D  Q
  1.  .D BSD
  1.  .D ALUV
  1.  K APCDVSIT
  1.  K APCDALVR
  1.  S APCDALVR("APCDAUTO")=""
  1.  S APCDALVR("APCDPAT")=APCDP
  1.  S APCDALVR("APCDCAT")="E"
  1.  S APCDALVR("APCDLOC")=DUZ(2)
  1.  S APCDALVR("APCDTYPE")=$S($P($G(^APCCCTRL(DUZ(2),0)),U,4)]"":$P(^APCCCTRL(DUZ(2),0),U,4),1:"O")
  1.  S APCDALVR("APCDDATE")=APCDD_".12"
  1.  D ^APCDALV
  1.  S APCDV=$G(APCDALVR("APCDVSIT"))
  1.  I $G(APCDALVR("APCDVSIT","NEW")) D DEDT^APCDEA2(APCDVSIT)
  1.  K APCDALVR
  1.  D ALUV
  1.  Q
  1. ALR(APCDTDA) ;EP - called from naA template to create ALR entry
  1.  D EN^XBNEW("ALR1^APCDAALG","APCDTDA")
  1.  Q
  1. ALR1 ;
  1.  ;create MLR entry on this visit
  1.  ;create V UPDATED/REVIEWED entry
  1.  NEW APCDALVR,APCDVAL
  1.  S APCDVAL=$O(^AUTTCRA("C","ALR",0))
  1.  S APCDALVR("APCDPAT")=$P(^AUPNVRUP(APCDTDA,0),U,2)
  1.  S APCDALVR("APCDVSIT")=$P(^AUPNVRUP(APCDTDA,0),U,3)
  1.  S APCDALVR("APCDATMP")="[APCDALVR 9000010.54 (ADD)]"
  1.  S APCDALVR("APCDTCLA")="`"_APCDVAL
  1.  S APCDALVR("APCDTCDT")=$P($G(^AUPNVRUP(APCDTDA,12)),U,1)
  1.  I $P($G(^AUPNVRUP(APCDTDA,12)),U,4) S APCDALVR("APCDTEPR")="`"_$P(^AUPNVRUP(APCDTDA,12),U,4)
  1.  D ^APCDALVR
  1.  I $D(APCDALVR("APCDAFLG")) S RETVAL=0_"^Error creating V UPDATED/REVIEWED entry.  PCC not updated."
  1.  K APCDALVR
  1.  Q