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

AQALDG4.m

Go to the documentation of this file. 
  1. AQALDG4 ; IHS/ORDC/LJF - AUTOLINK ADT OCCURRENCES ;
  1.  ;;1;QI LINKAGES-RPMS;;AUG 15, 1994
  1.  ;
  1.  ;PRIVATE ENTRY POINT between QI LINKAGES and ADT packages
  1.  ;Required input variables:  DFN=patient internal #
  1.  ;                           AQALADM=admission entry #
  1.  ;                           DUZ(2)=admission facility
  1.  ;                           AQALEV=ADT event # (field # in ^AQAGP)
  1.  ;                           AQALHSV=treating specialty
  1.  ;                           AQALTR=ward transfer ifn if aqalev=1031
  1.  ;
  1.  G EXIT1:'$D(DFN),EXIT1:'$D(AQALADM),EXIT1:AQALADM="",EXIT1:'$D(DUZ(2))
  1.  G EXIT1:'$D(AQALEV),EXIT1:'$D(AQALHSV)
  1.  I AQALEV=1031 G EXIT1:'$D(AQALTR)
  1.  I (AQALEV<1001)!(AQALEV>1061) G EXIT1
  1.  ;
  1. FIND ; >>> find variables for autolink rtn
  1.  K AQALIFN,AQALNKF ;kill occ internal # variable
  1.  G EXIT1:DFN="",EXIT1:'$D(^DPT(DFN,0)),EXIT1:$P(^(0),U,19)'=""
  1.  S AQALNK("BUL")="AQAL ADT EROR"
  1.  S AQALNK("PAT")=DFN ;patient
  1.  ;
  1.  ;check if event link turned on & find indicator # for event
  1.  G EXIT1:'$D(^AQAGP(DUZ(2))) ;no parameters for facility
  1.  I AQALEV=1031 D ICUCHK ;check which icu parameter applies
  1.  K ^UTILITY("DIQ1",$J) S AQALF=9002166.4
  1.  K DIC,DR S DIC="^AQAGP(",DA=DUZ(2)
  1.  S DR="" F I=0:1:3 S DR=DR_(AQALEV+I)_";"
  1.  D EN^DIQ1 G EXIT1:^UTILITY("DIQ1",$J,AQALF,DUZ(2),AQALEV)'="ON"
  1.  G EXIT:^UTILITY("DIQ1",$J,AQALF,DUZ(2),AQALEV+1)="" S X=^(AQALEV+1)
  1.  K DIC S DIC="^AQAO(2,",DIC(0)="" D ^DIC G EXIT:Y=-1 S AQALNK("IND")=+Y
  1.  ;
  1.  ;get occurrence date
  1.  S X=^UTILITY("DIQ1",$J,AQALF,DUZ(2),AQALEV+2) G EXIT:X=""
  1.  S Y="^DPT(DFN,""DA"",AQALADM,"_X_")"
  1.  G EXIT:'$D(@Y) ;gbl ref not exist
  1.  S AQALNK("DATE")=$P(+(@Y),".") ;occ date; full gbl above
  1.  G EXIT:AQALNK("DATE")=""
  1.  ;
  1.  ;get pcc visit (optional variable)
  1.  K AQALVST
  1.  S X=+^DPT(DFN,"DA",AQALADM,0) ;get admit date/time
  1.  S X=9999999-$P(X,".")_"."_$P(X,".",2),Y=0
  1.  F  S Y=$O(^AUPNVSIT("AA",DFN,X,Y)) Q:Y=""  Q:$D(AQALVST)  D
  1.  .Q:$P(^AUPNVSIT(Y,0),U,7)'="H"  ;make sure is hosp visit
  1.  .Q:$P(^AUPNVSIT(Y,0),U,11)=1  ;make sure not deleted
  1.  .S AQALVST=Y
  1.  S:$D(AQALVST) AQALNK("VSIT")=AQALVST
  1.  ;
  1.  ;get ward
  1.  S AQALNK("WARD")=$S($D(AQALWD):$P(^DIC(42,AQALWD,44),U),1:"")
  1.  ;
  1.  ;get hospital service linked to treating specialty
  1.  S AQALNK("HSV")=$S(AQALHSV="":"",1:$P(^DIC(45.7,AQALHSV,0),U,4))
  1.  S X=$O(^AQAGP(DUZ(2),"SRV","B",AQALNK("HSV"),0)) G EXIT1:X=""
  1.  Q:$P($G(^AQAGP(DUZ(2),"SRV",X,0)),U,($E(AQALEV,3)+2))'=1  ;srv not lnkd
  1.  ;
  1.  ;get facility #
  1.  G EXIT:'$D(DUZ(2)) S AQALNK("FAC")=DUZ(2)
  1.  ;
  1.  ;get duplicate flag (yes=okay to create duplicate entry)
  1.  S AQALNK("DUP OK")=^UTILITY("DIQ1",$J,AQALF,DUZ(2),AQALEV+3)
  1.  I AQALNK("DUP OK")'="YES" K AQALNK("DUP OK")
  1.  ;
  1.  ;
  1. CREATE ; >>> call ^aqalnk to create occurrence
  1.  D CREATE^AQALNK
  1.  G EXIT
  1.  ;
  1.  ;
  1. CHECK ; >>> check results
  1.  G ERRORMSG:'$D(AQALIFN) ;go print error messages
  1.  ;print occ message and exit
  1.  W !!,"QAI Occurrence entry created for this transaction: "
  1.  W " (",$P($P(^DD(AQALF,AQALEV,0),U),"LINK"),")",! G EXIT
  1.  ;
  1. ERRORMSG ; >>> send bulletin if any error messages exist
  1.  S XMB="AQAL ADT ERROR",XMDUZ="QI LINKAGES MESSENGER"
  1.  S X=0 F  S X=$O(^AQAO(9,"AC","QA",X)) Q:X=""
  1.  .S XMY(X)="",XMY(X,1)="I" ;set pkg admin as recipients-info only
  1.  S AQALAR(1)="PATIENT IS "_$P($G(^DPT(AQALPAT,0)),U)
  1.  S AQALAR(2)="CHART #"_$P($G(^AUPNPAT(AQALPAT,41,DUZ(2),0)),U,2)
  1.  S X=0,Y=2 F  S X=$O(AQALNKF(X)) Q:X=""  S Y=Y+1,AQALAR(Y)=AQALNKF(X)
  1.  S XMTEXT="AQALAR(" D ^XMB K XMB,XMDUX,XMY,XMTEXT
  1.  ;
  1. EXIT ; >>> eoj
  1.  I '$D(AQALIFN),'$D(AQALNKF) W !!,*7,"ERROR IN QI PARAMETER FILE OR IN ADT CALL TO ^AQALDG. CALL YOUR SITE MANAGER.",!!
  1. EXIT1 K ^UTILITY("DIQ1",$J)
  1.  D ^AQALKILL
  1.  Q
  1.  ;
  1.  ;
  1. ICUCHK ; >>SUBRTN to see which ICU parameter applies
  1.  Q:$P(^AQAGP(DUZ(2),"ADT"),U,71)'=1  ;return to icu not turned on
  1.  N AQALDT,AQALX,Y,X
  1.  S AQALDT=+$G(^DPT(DFN,41,AQALADM,2,AQALTR,0)) ;transfer date/time
  1.  Q:AQALDT=0  S AQALX=10000000-AQALDT
  1.  F  S AQALX=$O(^DPT(DFN,41,AQALADM,2,"ATT",AQALX)) Q:AQALX=""  D
  1.  .S Y=$O(^DPT(DFN,41,AQALADM,2,"ATT",AQALX,0)) Q:Y=""
  1.  .S X=$P(^DPT(DFN,41,AQALADM,2,Y,0),U,4) Q:X=""
  1.  .Q:$P(^DIC(42,X,"IHS"),U)'="Y"  ;previous ward not icu
  1.  .S X1=$P(^DPT(DFN,41,AQALADM,2,Y,0),U),X2=AQALDT D ^%DTC
  1.  .I %Y,(X'>$P(^AQAGP(DUZ(2),"ADT"),U,75)) S AQALEV=1071
  1.  Q:AQALEV=1071  ;return to icu within time limit
  1.  S X=$P(^DPT(DFN,41,AQALADM,0),U,4) Q:X=""
  1.  Q:$P(^DIC(42,X,"IHS"),U)'="Y"  ;admitting ward not icu
  1.  S X1=+^DPT(DFN,41,AQALADM,0),X2=AQALDT D ^%DTC
  1.  I %Y,(X'>$P(^AQAGP(DUZ(2),"ADT"),U,75)) S AQALEV=1071
  1.  Q