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