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

BQIDCAH3.m

Go to the documentation of this file. 
  1. BQIDCAH3 ;VNGT/HS/ALA-Ad Hoc continued ; 22 Apr 2011  12:02 PM
  1.  ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
  1.  ;
  1. LAB(FGLOB,TGLOB,LAB,LABTX,FDT,TDT,LNOT,MPARMS,MAPARMS) ;EP - Lab test search
  1.  NEW LTAX,TREF,NGLOB,LCT,CT,IEN,RVAL,LB
  1.  S NGLOB=$NA(^TMP("BQIDCLAB",$J)) K @NGLOB
  1.  K LBPT
  1.  I $G(TGLOB)="" Q
  1.  I $D(APARMS)!($D(MAPARMS)) D  Q
  1.  . I LBOP="!" D
  1.  .. S LAB=""
  1.  .. F  S LAB=$O(APARMS("LAB",LAB)) Q:LAB=""  D
  1.  ... S RVAL=$O(APARMS("LAB",LAB,""))
  1.  ... I RVAL="NUMLAB" S NUMLAB=APARMS("LAB",LAB,"NUMLAB")
  1.  ... I RVAL="SETLAB" S SETLAB=APARMS("LAB",LAB,"SETLAB")
  1.  ... D LB
  1.  .. S LAB=""
  1.  .. F  S LAB=$O(MAPARMS("LAB",LAB)) Q:LAB=""  D LB
  1.  . I LBOP="&" D
  1.  .. ;K LBPT
  1.  .. S LAB="",CT=0
  1.  .. F  S LAB=$O(APARMS("LAB",LAB)) Q:LAB=""  D  S CT=CT+1
  1.  ... S RVAL=$O(APARMS("LAB",LAB,""))
  1.  ... I RVAL="NUMLAB" S NUMLAB=APARMS("LAB",LAB,"NUMLAB")
  1.  ... I RVAL="SETLAB" S SETLAB=APARMS("LAB",LAB,"SETLAB")
  1.  ... D LB
  1.  .. S LAB=""
  1.  .. F  S LAB=$O(MAPARMS("LAB",LAB)) Q:LAB=""  D LB
  1.  .. S LAB="" K NUMLAB,SETLAB
  1.  .. F  S LAB=$O(MPARMS("LAB",LAB)) Q:LAB=""  D
  1.  ... S:'$D(APARMS("LAB",LAB)) CT=CT+1
  1.  ... I '$D(APARMS("LAB",LAB)) D LB
  1.  .. S IEN=""
  1.  .. F  S IEN=$O(LBPT(IEN)) Q:IEN=""  D
  1.  ... S LCT=0,LB=""
  1.  ... F  S LB=$O(LBPT(IEN,LB)) Q:LB=""  S LCT=LCT+1
  1.  ... I LCT=CT,'LNOT D
  1.  .... S @TGLOB@(IEN)="",LB=""
  1.  .... F  S LB=$O(LBPT(IEN,LB)) Q:LB=""  D
  1.  ..... S LIEN=""
  1.  ..... F  S LIEN=$O(LBPT(IEN,LB,LIEN)) Q:LIEN=""  S @CRIT@("LAB",IEN,LIEN)=""
  1.  ... I LCT=CT,LNOT S @NGLOB@(IEN)="" K @CRIT@("LAB",IEN)
  1.  I $G(LAB)'="" D LB
  1.  I $G(LABTX)'="" D
  1.  . S TREF=$NA(MPARMS("LAB"))
  1.  . K @TREF
  1.  . S LTAX=$P(@("^"_$P(LABTX,";",2)_$P(LABTX,";",1)_",0)"),"^",1)
  1.  . I LABTX["ATXAX" D BLD^BQITUTL(LTAX,TREF)
  1.  . I LABTX["ATXLAB" D BLD^BQITUTL(LTAX,TREF,"L")
  1.  I LBOP="!" D
  1.  . I $D(MPARMS("LAB")) S LAB="" F  S LAB=$O(MPARMS("LAB",LAB)) Q:LAB=""  D LB
  1.  I LBOP="&" D
  1.  . K LBPT
  1.  . S LAB="",CT=0 F  S LAB=$O(MPARMS("LAB",LAB)) Q:LAB=""  D LB S CT=CT+1
  1.  . S IEN=""
  1.  . F  S IEN=$O(LBPT(IEN)) Q:IEN=""  D
  1.  .. S LCT=0,LB=""
  1.  .. F  S LB=$O(LBPT(IEN,LB)) Q:LB=""  S LCT=LCT+1
  1.  .. I LCT=CT,'LNOT D
  1.  ... S @TGLOB@(IEN)="",LB=""
  1.  ... F  S LB=$O(LBPT(IEN,LB)) Q:LB=""  D
  1.  .... S LIEN=""
  1.  .... F  S LIEN=$O(LBPT(IEN,LB,LIEN)) Q:LIEN=""  S @CRIT@("LAB",IEN,LIEN)=""
  1.  .. I LCT=CT,LNOT S @NGLOB@(IEN)="" K @CRIT@("LAB",IEN)
  1.  ;
  1.  I LNOT,$G(FGLOB)'="" D
  1.  . S IEN="" F  S IEN=$O(@FGLOB@(IEN)) Q:IEN=""  D
  1.  .. I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
  1.  I LNOT,$G(FGLOB)="" D
  1.  . S IEN=0 F  S IEN=$O(^AUPNPAT(IEN)) Q:'IEN  I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
  1.  K @NGLOB
  1.  Q
  1.  ;
  1. LB ;EP
  1.  NEW DFN,IEN,LBRES,RES,LOK,LURES,LBURNP
  1.  S TDT=$S(TDT'="":TDT,1:DT)
  1.  I $G(FGLOB)'="" D  Q
  1.  . NEW IEN
  1.  . S IEN=""
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D
  1.  .. I $O(^AUPNVLAB("AA",IEN,LAB,""))="" Q
  1.  .. I FDT="" D
  1.  ... S BDT=""
  1.  ... F  S BDT=$O(^AUPNVLAB("AA",IEN,LAB,BDT)) Q:BDT=""  D LBDT
  1.  .. I FDT'="" D
  1.  ... S BGT=9999999-FDT,ENT=9999999-TDT,BDT=ENT-1
  1.  ... F  S BDT=$O(^AUPNVLAB("AA",IEN,LAB,BDT)) Q:BDT=""!(BDT>BGT)  D LBDT
  1.  ;
  1.  S IEN=""
  1.  F  S IEN=$O(^AUPNVLAB("B",LAB,IEN)) Q:IEN=""  D
  1.  . I $G(^AUPNVLAB(IEN,0))="" Q
  1.  . S DFN=$P($G(^AUPNVLAB(IEN,0)),U,2),VIS=$P(^AUPNVLAB(IEN,0),U,3) I VIS="" Q
  1.  . I $G(^AUPNVSIT(VIS,0))="" Q
  1.  . Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
  1.  . S VSDTM=$P(^AUPNVSIT(VIS,0),U,1)\1
  1.  . I FDT'="",VSDTM<FDT!(VSDTM>TDT) Q
  1.  . S LBRES=$P($G(^AUPNVLAB(IEN,0)),U,4),LURES=$$UP^XLFSTR(LBRES)
  1.  . S LBRSN=$$PUNC^BQIUL3(LBRES),LBURNP=$$PUNC^BQIUL3(LURES)
  1.  . ; If looking for a lab result
  1.  . S RES=0
  1.  . I $G(SETLAB)="",$G(NUMLAB)="",'$D(MAPARMS("LAB",LAB,"SETLAB")),'$D(MAPARMS("LAB",LAB,"NUMLAB")) S ROK=0,RES=1,LOK=1
  1.  . I $G(SETLAB)'=""!($G(NUMLAB)'="")!($D(MAPARMS("LAB",LAB,"SETLAB")))!($D(MAPARMS("LAB",LAB,"NUMLAB"))) S ROK=1,LOK=0 D LBR
  1.  . I LBOP="!",'LNOT D  Q
  1.  .. I ROK,'RES Q
  1.  .. S @TGLOB@(DFN)=""
  1.  .. I LOK S @CRIT@("LAB",DFN,IEN)=""
  1.  . I LBOP="!",LNOT D  Q
  1.  .. I ROK,'RES Q
  1.  .. S @NGLOB@(DFN)=""
  1.  .. I LOK S @CRIT@("LAB",DFN,IEN)=""
  1.  . I LBOP="&" D  Q
  1.  .. I ROK,'RES Q
  1.  .. ;S LBPT(DFN,LAB,IEN)=IEN_U_LBRES B
  1.  .. S LBPT(DFN,LAB,IEN)=""
  1.  .. I LOK S @CRIT@("LAB",DFN,IEN)=""
  1.  ;
  1.  Q
  1.  ;
  1. LBDT ;EP - Date search
  1.  S LIEN=""
  1.  F  S LIEN=$O(^AUPNVLAB("AA",IEN,LAB,BDT,LIEN)) Q:LIEN=""  D
  1.  . S VIS=$P($G(^AUPNVLAB(LIEN,0)),U,3) I VIS="" Q
  1.  . I $G(^AUPNVSIT(VIS,0))="" Q
  1.  . Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
  1.  . S LBRES=$P($G(^AUPNVLAB(LIEN,0)),U,4),LURES=$$UP^XLFSTR(LBRES)
  1.  . S LBRSN=$$PUNC^BQIUL3(LBRES),LBURNP=$$PUNC^BQIUL3(LURES)
  1.  . ; If looking for a lab result
  1.  . S RES=0
  1.  . I $G(SETLAB)="",$G(NUMLAB)="",'$D(MAPARMS("LAB",LAB,"SETLAB")),'$D(MAPARMS("LAB",LAB,"NUMLAB")) S ROK=0,RES=1,LOK=1
  1.  . I $G(SETLAB)'=""!($G(NUMLAB)'="")!($D(MAPARMS("LAB",LAB,"SETLAB")))!($D(MAPARMS("LAB",LAB,"NUMLAB"))) S ROK=1,LOK=0 D LBR
  1.  . I LBOP="!",'LNOT D  Q
  1.  .. I ROK,'RES Q
  1.  .. S @TGLOB@(IEN)=""
  1.  .. I LOK S @CRIT@("LAB",IEN,LIEN)=""
  1.  . I LBOP="!",LNOT D  Q
  1.  .. I ROK,'RES Q
  1.  .. S @NGLOB@(IEN)=""
  1.  .. I LOK S @CRIT@("LAB",IEN,LIEN)=""
  1.  . I LBOP="&" D  Q
  1.  .. I ROK,'RES Q
  1.  .. ;S LBPT(IEN,LAB)=LIEN_U_LBRES
  1.  .. S LBPT(IEN,LAB,LIEN)=""
  1.  .. I LOK S @CRIT@("LAB",IEN,LIEN)=""
  1.  Q
  1.  ;
  1. LBR ;EP - Lab results
  1.  I LBRES="" Q
  1.  NEW LBR,VCRIT1,VCRIT2,ROPER,OPER,OPER2,RES1,RES2,SCODE,LI,LBRS,FQL
  1.  I $G(SETLAB)'="",LBRES=SETLAB S LOK=1,RES=1 Q
  1.  I $G(SETLAB)'="",LBRES'=SETLAB D  Q
  1.  . I SETLAB=LURES S LOK=1,RES=1 Q
  1.  . S SCODE=$$LSET(LAB)
  1.  . D SCD
  1.  ;
  1.  ;I $G(SETLAB)'="",'$D(MAPARMS("LAB",LAB,"SETLAB")),LBRES=$P(SCODE,":",1)!(LBRES=$P(SCODE,":",2)) S LOK=1,RES=1 Q
  1.  I $D(MAPARMS("LAB",LAB,"SETLAB")) D  Q
  1.  . S LBR="" F  S LBR=$O(MAPARMS("LAB",LAB,"SETLAB",LBR)) Q:LBR=""  D  Q:LOK
  1.  .. I LBRES=LBR S LOK=1,RES=1 Q
  1.  .. S SCODE=$$LSET(LAB)
  1.  .. NEW SETLAB
  1.  .. S SETLAB=LBR D SCD
  1.  ;
  1.  I $G(NUMLAB)'="" D  Q
  1.  . ;NEW REX,R
  1.  . ;S R=0,REX=0 F  S R=$O(^BQICARE(OWNR,1,PLIEN,5,R)) Q:'R  I ^BQICARE(OWNR,1,PLIEN,5,R,0)["exclusive" S REX=1
  1.  . NEW REX
  1.  . I NUMLAB["~" S REX=1
  1.  . I NUMLAB["~",NUMLAB["'" S REX=0
  1.  . I LBRES?.ULP Q
  1.  . I LBRES'?.PN,LBRES'?.N Q
  1.  . I $E(LBRES,$L(LBRES),$L(LBRES))?.P S LBRES=$E(LBRES,1,$L(LBRES)-1)
  1.  . ; if value starts with a punctuation e.g. < or >
  1.  . I $E(LBRES,1,1)?.P S ROPER=$E(LBRES,1,1),LBRES=$E(LBRES,2,$L(LBRES))
  1.  . I NUMLAB["~" S VCRIT1=$P(NUMLAB,"~",1),VCRIT2=$P(NUMLAB,"~",2)
  1.  . E  S VCRIT1=NUMLAB,VCRIT2=""
  1.  . F I=1:1:$L(VCRIT1) Q:$E(VCRIT1,I,I)'?.P
  1.  . S OPER=$E(VCRIT1,1,I-1),RES1=$E(VCRIT1,I,$L(VCRIT1))
  1.  . I $E(OPER,$L(OPER),$L(OPER))="." D
  1.  .. S OPER=$E(OPER,1,$L(OPER)-1),RES1="."_RES1
  1.  . I $G(VCRIT2)'="" D
  1.  .. F I=1:1:$L(VCRIT2) Q:$E(VCRIT2,I,I)'?.P
  1.  .. S OPER2=$E(VCRIT2,1,I-1),RES2=$E(VCRIT2,I,$L(VCRIT2))
  1.  .. I $E(OPER2,$L(OPER2),$L(OPER2))="." D
  1.  ... S OPER2=$E(OPER2,1,$L(OPER2)-1),RES2="."_RES2
  1.  . I VCRIT2="" D
  1.  .. I $G(ROPER)="",@("LBRES"_OPER_"RES1") S LOK=1,RES=1 Q
  1.  .. I $G(ROPER)'="",OPER=ROPER,@("LBRES"_OPER_"RES1") S LOK=1,RES=1 Q
  1.  .. I $G(ROPER)'="",OPER'=ROPER Q
  1.  . I VCRIT2'="" D
  1.  .. I @("LBRES"_OPER_"RES1"),@("LBRES"_OPER2_"RES2") S LOK=1,RES=1
  1.  .. I REX D
  1.  ... I @("LBRES"_OPER_"RES1") S LOK=1,RES=1
  1.  ... I @("LBRES"_OPER2_"RES2") S LOK=1,RES=1
  1.  Q
  1.  ;
  1. SCD ;EP
  1.  NEW LCOD,LCODU,LCODP,LVAL,LVALU,LVALP
  1.  F LI=1:1:$L(SCODE,";") S FQL=0 D  Q:FQL
  1.  . S LBRS=$P(SCODE,";",LI),ROK=1,RES=0
  1.  . NEW LCOD,LCODU,LCODP
  1.  . ; Set code exactly, set code uppercase, set code no punctuation
  1.  . S LCOD=$P(LBRS,":",1),LCODU=$$UP^XLFSTR(LCOD),LCODP=$$PUNC^BQIUL3(LCOD)
  1.  . ; Set value exactly, set value uppercase, set value no punctuation
  1.  . S LVAL=$P(LBRS,":",2),LVALU=$$UP^XLFSTR(LVAL),LVALP=$$PUNC^BQIUL3(LVAL)
  1.  . ;
  1.  . ; If the set code matches the actual lab result
  1.  . I SETLAB=LCOD D  Q
  1.  .. I LBRES=LCOD S LOK=1,RES=1,FQL=1 Q
  1.  .. I LURES=LCODU S LOK=1,RES=1,FQL=1 Q
  1.  .. I LBURNP=LCODP S LOK=1,RES=1,FQL=1 Q
  1.  .. I LBRES=LVAL S LOK=1,RES=1,FQL=1 Q
  1.  .. I LURES=LVALU S LOK=1,RES=1,FQL=1 Q
  1.  .. I LBURNP=LVALP S LOK=1,RES=1,FQL=1 Q
  1.  Q
  1.  ;
  1. LSET(LN) ;EP - Set of codes for lab test
  1.  NEW VALUE,TYP
  1.  I $G(^LAB(60,LN,0))="" Q VALUE
  1.  S TYP=$P(^LAB(60,LN,0),"^",12),VALUE=""
  1.  I TYP'="" D
  1.  . NEW FLD,TEST
  1.  . S FLD=$P(TYP,",",2)
  1.  . D FIELD^DID(63.04,FLD,"","*","TEST")
  1.  . S VALUE=$G(TEST("POINTER"))
  1.  Q VALUE
  1.  ;
  1. MED(FGLOB,TGLOB,MED,MEDTX,FDT,TDT,MNOT,MPARMS) ;EP - Medication search
  1.  NEW MDPT,TREF,MTAX,NGLOB,MIEN,MCT,CT
  1.  S NGLOB=$NA(^TMP("BQIDCMED",$J)) K @NGLOB
  1.  I $G(TGLOB)="" Q
  1.  I $G(MED)'="" D MD
  1.  I $G(MEDTX)'="" D
  1.  . S TREF=$NA(MPARMS("MED"))
  1.  . K @TREF
  1.  . S MTAX=$P(@("^"_$P(MEDTX,";",2)_$P(MEDTX,";",1)_",0)"),"^",1)
  1.  . D BLD^BQITUTL(MTAX,TREF)
  1.  I MDOP="!" D
  1.  . I $D(MPARMS("MED")) S MED="" F  S MED=$O(MPARMS("MED",MED)) Q:MED=""  D MD
  1.  I MDOP="&" D
  1.  . K MDPT
  1.  . S MED="",CT=0 F  S MED=$O(MPARMS("MED",MED)) Q:MED=""  D MD S CT=CT+1
  1.  . S IEN=""
  1.  . F  S IEN=$O(MDPT(IEN)) Q:IEN=""  D
  1.  .. S MCT=0,MD=""
  1.  .. F  S MD=$O(MDPT(IEN,MD)) Q:MD=""  S MCT=MCT+1
  1.  .. I MCT=CT,'MNOT D
  1.  ... S @TGLOB@(IEN)=""
  1.  ... F  S MD=$O(MDPT(IEN,MD)) Q:MD=""  S MIEN=MDPT(IEN,MD),@CRIT@("MED",IEN,MIEN)=""
  1.  .. I MCT=CT,MNOT S @NGLOB@(IEN)="" K @CRIT@("MED",IEN)
  1.  ;
  1.  I MNOT,$G(FGLOB)'="" D
  1.  . S IEN="" F  S IEN=$O(@FGLOB@(IEN)) Q:IEN=""  D
  1.  .. I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
  1.  I MNOT,$G(FGLOB)="" D
  1.  . S IEN=0 F  S IEN=$O(^AUPNPAT(IEN)) Q:'IEN  I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
  1.  K @NGLOB
  1.  Q
  1.  ;
  1. MD ;EP
  1.  NEW DFN,IEN
  1.  S TDT=$S(TDT'="":TDT,1:DT)
  1.  I $G(FGLOB)'="" D  Q
  1.  . NEW IEN,MDP
  1.  . S IEN=""
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D
  1.  .. I FDT="" D
  1.  ... S BDT=""
  1.  ... F  S BDT=$O(^AUPNVMED("AA",IEN,BDT)) Q:BDT=""  D MDDT
  1.  .. I FDT'="" D
  1.  ... S BGT=9999999-FDT,ENT=9999999-TDT,BDT=ENT-1
  1.  ... F  S BDT=$O(^AUPNVMED("AA",IEN,BDT)) Q:BDT=""!(BDT>BGT)  D MDDT
  1.  ;
  1.  S IEN=""
  1.  F  S IEN=$O(^AUPNVMED("B",MED,IEN)) Q:IEN=""  D
  1.  . I $G(^AUPNVMED(IEN,0))="" Q
  1.  . S DFN=$P(^AUPNVMED(IEN,0),U,2),VIS=$P(^AUPNVMED(IEN,0),U,3) I VIS="" Q
  1.  . I $G(^AUPNVSIT(VIS,0))="" Q
  1.  . Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
  1.  . S VSDTM=$P(^AUPNVSIT(VIS,0),U,1)\1
  1.  . I FDT'="",VSDTM<FDT!(VSDTM>TDT) Q
  1.  . I DFN'="",MDOP="!",MNOT S @NGLOB@(DFN)="" Q
  1.  . I DFN'="",MDOP="!",'MNOT S @TGLOB@(DFN)="",@CRIT@("MED",DFN,IEN)="" Q
  1.  . I DFN'="",MDOP="&" S MDPT(DFN,MED)=IEN
  1.  Q
  1.  ;
  1. MDDT ; EP
  1.  S MIEN=""
  1.  F  S MIEN=$O(^AUPNVMED("AA",IEN,BDT,MIEN)) Q:MIEN=""  D
  1.  . S MDP=$P($G(^AUPNVMED(MIEN,0)),U,1)
  1.  . I MDOP="!",MDP=MED,MNOT S @NGLOB@(IEN)="" Q
  1.  . I MDOP="!",MDP=MED,'MNOT S @TGLOB@(IEN)="",@CRIT@("MED",IEN,MIEN)="" Q
  1.  . I MDOP="&",MDP=MED S MDPT(IEN,MED)=MIEN
  1.  Q
  1.  ;
  1. CPT(FGLOB,TGLOB,CPT,CPTTX,FDT,TDT,CNOT,MPARMS) ;EP - CPT test search
  1.  NEW CPPT,CTAX,TREF,NGLOB,LCT,CT,IEN
  1.  S NGLOB=$NA(^TMP("BQIDCCPT",$J)) K @NGLOB
  1.  I $G(TGLOB)="" Q
  1.  I $G(CPT)'="" D CP
  1.  I $G(CPTTX)'="" D
  1.  . S TREF=$NA(MPARMS("CPT"))
  1.  . K @TREF
  1.  . S CTAX=$P(@("^"_$P(CPTTX,";",2)_$P(CPTTX,";",1)_",0)"),"^",1)
  1.  . D BLD^BQITUTL(CTAX,TREF)
  1.  I CPOP="!" D
  1.  . I $D(MPARMS("CPT")) S CPT="" F  S CPT=$O(MPARMS("CPT",CPT)) Q:CPT=""  D CP
  1.  I CPOP="&" D
  1.  . K CPPT
  1.  . S CPT="",CT=0 F  S CPT=$O(MPARMS("CPT",CPT)) Q:CPT=""  D CP S CT=CT+1
  1.  . S IEN=""
  1.  . F  S IEN=$O(CPPT(IEN)) Q:IEN=""  D
  1.  .. S LCT=0,LB=""
  1.  .. F  S LB=$O(CPPT(IEN,LB)) Q:LB=""  S LCT=LCT+1
  1.  .. I LCT'=CT K CPPT(IEN),@CRIT@("CPT",IEN) Q
  1.  .. I LCT=CT,'CNOT S @TGLOB@(IEN)="" Q
  1.  .. I LCT=CT,CNOT S @NGLOB@(IEN)="" K @CRIT@("CPT",IEN)
  1.  ;
  1.  I CNOT,$G(FGLOB)'="" D
  1.  . S IEN="" F  S IEN=$O(@FGLOB@(IEN)) Q:IEN=""  D
  1.  .. I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
  1.  I CNOT,$G(FGLOB)="" D
  1.  . S IEN=0 F  S IEN=$O(^AUPNPAT(IEN)) Q:'IEN  I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
  1.  K @NGLOB
  1.  Q
  1.  ;
  1. CP ;EP
  1.  NEW DFN,IEN
  1.  S TDT=$S(TDT'="":TDT,1:DT)
  1.  I $G(FGLOB)'="" D  Q
  1.  . NEW IEN
  1.  . S IEN=""
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D
  1.  .. I $O(^AUPNVCPT("AA",IEN,CPT,""))="" Q
  1.  .. I FDT="" D
  1.  ... S BDT=""
  1.  ... F  S BDT=$O(^AUPNVCPT("AA",IEN,CPT,BDT)) Q:BDT=""  D CPDT
  1.  .. I FDT'="" D
  1.  ... S BGT=9999999-FDT,ENT=9999999-TDT,BDT=ENT-1
  1.  ... F  S BDT=$O(^AUPNVCPT("AA",IEN,CPT,BDT)) Q:BDT=""!(BDT>BGT)  D CPDT
  1.  ;
  1.  S IEN=""
  1.  F  S IEN=$O(^AUPNVCPT("B",CPT,IEN)) Q:IEN=""  D
  1.  . I $G(^AUPNVCPT(IEN,0))="" Q
  1.  . S DFN=$P($G(^AUPNVCPT(IEN,0)),U,2),VIS=$P(^AUPNVCPT(IEN,0),U,3) I VIS="" Q
  1.  . I $G(^AUPNVSIT(VIS,0))="" Q
  1.  . Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
  1.  . S VSDTM=$P(^AUPNVSIT(VIS,0),U,1)\1
  1.  . I FDT'="",VSDTM<FDT!(VSDTM>TDT) Q
  1.  . I DFN'="",CPOP="!",'CNOT S @TGLOB@(DFN)="",@CRIT@("CPT",DFN,IEN)="" Q
  1.  . I DFN'="",CPOP="!",CNOT S @NGLOB@(DFN)="" Q
  1.  . I DFN'="",CPOP="&" S CPPT(DFN,CPT)=IEN
  1.  ;
  1.  Q
  1.  ;
  1. CPDT ;EP
  1.  S LIEN=""
  1.  F  S LIEN=$O(^AUPNVCPT("AA",IEN,CPT,BDT,LIEN)) Q:LIEN=""  D
  1.  . S VIS=$P($G(^AUPNVCPT(LIEN,0)),U,3) I VIS="" Q
  1.  . I $G(^AUPNVSIT(VIS,0))="" Q
  1.  . Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
  1.  . I CPOP="!",'CNOT S @TGLOB@(IEN)=LIEN,@CRIT@("CPT",IEN,LIEN)="" Q
  1.  . I CPOP="!",CNOT S @NGLOB@(IEN)="" Q
  1.  . I CPOP="&" S CPPT(IEN,CPT)=LIEN
  1.  Q