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

QAOSPSM0.m

Go to the documentation of this file. 
  1. QAOSPSM0 ;HISC/DAD-SUMMARY OF OCCURRENCE SCREENING - GET DATA ;12/8/93  11:51
  1.  ;;3.0;Occurrence Screen;**2,5**;09/14/1993
  1.  K ^UTILITY($J,"QAOSPSM"),^UTILITY($J,"QAOSXREF"),^UTILITY($J,"QAOSPEND")
  1.  K QAOSACTN,QAOSRV S QAOSLIST=""
  1.  F QA=1:1:$L(QAOSLIST(0),",") D
  1.  . S QAO=$P(QAOSLIST(0),",",QA)
  1.  . S QAOSLIST=QAOSLIST_$S(QAO="1":"^N",QAO=2:"^L",QAO=3:"^1",1:"^")
  1.  . Q
  1.  S (QAOSNUM("N"),QAOSNUM("L"),QAOSNUM("1"))=1
  1.  F QAOSCRN=0:0 S QAOSCRN=$O(^QA(741.1,"B",QAOSCRN)) Q:QAOSCRN'>0  D
  1.  . F QAOSD0=0:0 S QAOSD0=$O(^QA(741.1,"B",QAOSCRN,QAOSD0)) Q:QAOSD0'>0  D
  1.  .. S QAOS=$G(^QA(741.1,QAOSD0,0)),QA=$P(QAOS,"^",4)
  1.  .. Q:QAOSLIST'[("^"_QA_"^")
  1.  .. S ^UTILITY($J,"QAOSPSM",QA,QAOSNUM(QA))=+QAOS
  1.  .. S ^UTILITY($J,"QAOSXREF",+QAOS)=QAOSNUM(QA)_"^"_QA
  1.  .. S QAOSNUM(QA)=QAOSNUM(QA)+1
  1.  .. Q
  1.  . Q
  1.  S QAOSCLIN=+$O(^QA(741.2,"C",1,0)),QAOSPEER=+$O(^QA(741.2,"C",2,0))
  1.  S QAOSMGMT=+$O(^QA(741.2,"C",3,0)),QAOSRFPR=+$O(^QA(741.7,"B",2,0))
  1.  F QA=1:1:16 S QAOSFIND(QA)=+$O(^QA(741.6,"B",QA,0))
  1.  F QAOSDATE=QAQNBEG-.0000001:0 S QAOSDATE=$O(^QA(741,"C",QAOSDATE)) Q:(QAOSDATE'>0)!(QAOSDATE>(QAQNEND+.9999999))  F QAOSD0=0:0 S QAOSD0=$O(^QA(741,"C",QAOSDATE,QAOSD0)) Q:QAOSD0'>0  D LOOP1
  1.  Q
  1. LOOP1 ;
  1.  S QAOSZERO=$G(^QA(741,QAOSD0,0)) Q:(QAOSZERO="")!($P(QAOSZERO,"^",11)=2)
  1.  S QAOSSCRN=+$G(^QA(741,QAOSD0,"SCRN"))
  1.  S QAOSSCRN(0)=$G(^QA(741.1,QAOSSCRN,0))
  1.  S QAO=$G(^UTILITY($J,"QAOSXREF",+QAOSSCRN(0))),QAOSSEQ=+QAO
  1.  S QAOSSTAT=$P(QAO,"^",2) Q:QAOSLIST'[("^"_QAOSSTAT_"^")
  1.  S QAOSD1=+$O(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,0))
  1.  S QAOSCREV=$G(^QA(741,QAOSD0,"REVR",QAOSD1,0))
  1.  ; If Exist(Peer) &' Exist(Clin) set QAOSCREV="."
  1.  I QAOSCREV="",$O(^QA(741,QAOSD0,"REVR","B",QAOSPEER,0)) S QAOSCREV="."
  1.  Q:QAOSCREV=""  ;  NO CLIN & NO PEER
  1.  S QAOSFIND=+$P(QAOSCREV,"^",5) Q:QAOSFIND=QAOSFIND(3)  ;  EXCEPTION
  1.  ;
  1.  ;  MGMT actions
  1.  K SERV S QAOSS1=0
  1.  F  S QAOSS1=$O(^QA(741,QAOSD0,"REVR","B",QAOSMGMT,QAOSS1)) Q:QAOSS1'>0  D
  1.  . S QA=$G(^QA(741,QAOSD0,"REVR",QAOSS1,0)),SERV=+$P(QA,"^",10)
  1.  . Q:$G(SERV(SERV))  S SERV(SERV)=1,QAOSS2=0
  1.  . F  S QAOSS2=$O(^QA(741,QAOSD0,"REVR",QAOSS1,2,QAOSS2)) Q:QAOSS2'>0  D
  1.  .. S Y=+^QA(741,QAOSD0,"REVR",QAOSS1,2,QAOSS2,0),X=+$G(^QA(741.7,Y,0))
  1.  .. S QAOSACTN(QAOSSTAT,X)=$G(QAOSACTN(QAOSSTAT,X))+1
  1.  .. Q
  1.  . Q
  1.  ;  BED SERVICE SPECIFIC occur
  1.  S QAOSHOSP=+$P(QAOSZERO,"^",5)
  1.  S QAOSHOSP(0)=$G(^SC(QAOSHOSP,0))
  1.  I $P(QAOSHOSP(0),"^",3)="C" D
  1.  . S SERV=$P(QAOSHOSP(0),"^",8)
  1.  . S:SERV="N" SERV="NE"
  1.  . Q
  1.  E  D
  1.  . S QAOSWARD=+$G(^SC(QAOSHOSP,42))
  1.  . S SERV=$P($G(^DIC(42,QAOSWARD,0)),"^",3)
  1.  . Q
  1.  S Y=+$P("^M1^NE1^S2^P3^I4^NH4^R4^SCI4^D4^B4","^"_SERV,2)
  1.  I Y D
  1.  . S X=1+$P($G(QAOSRV(QAOSSTAT,QAOSSEQ)),"^",Y)
  1.  . S $P(QAOSRV(QAOSSTAT,QAOSSEQ),"^",Y)=X
  1.  . S X=1+$P($G(QAOSRV(QAOSSTAT,QAOSSEQ)),"^",5)
  1.  . S $P(QAOSRV(QAOSSTAT,QAOSSEQ),"^",5)=X
  1.  . Q
  1.  S QAOSTEMP=^UTILITY($J,"QAOSPSM",QAOSSTAT,QAOSSEQ)
  1.  ;  # OCCUR REVIEWED CLINICALLY
  1.  I QAOSCREV'="." S $P(QAOSTEMP,"^",2)=$P(QAOSTEMP,"^",2)+1
  1.  ;  # OCCUR REFERRED PEER (CLIN & NO PEER FOUND)
  1.  I $O(^QA(741,QAOSD0,"REVR",QAOSD1,2,"B",QAOSRFPR,0)) D
  1.  . I $O(^QA(741,QAOSD0,"REVR","B",QAOSPEER,0))'>0 D
  1.  .. S $P(QAOSTEMP,"^",3)=$P(QAOSTEMP,"^",3)+1 ; # REFERRED PEER
  1.  .. S $P(QAOSTEMP,"^",7)=$P(QAOSTEMP,"^",7)+1 ; PEER: PENDING
  1.  .. D PEND(1)
  1.  .. Q
  1.  . Q
  1.  ;  OUTCOME PEER: LEVELS 1,2,3
  1.  K SERV S QAOSS1=0
  1.  F  S QAOSS1=$O(^QA(741,QAOSD0,"REVR","AONLY1",1,QAOSS1)) Q:QAOSS1'>0  D
  1.  . S QA=$G(^QA(741,QAOSD0,"REVR",QAOSS1,0))
  1.  . Q:($P(QA,"^")'=QAOSPEER)!($P(QA,"^",9)'>0)  ;  NOT PEER ! NOT FINAL
  1.  . S QAOSLEVL=$P(QA,"^",5),SERV=+$P(QA,"^",10),SERV(SERV)=1
  1.  . S $P(QAOSTEMP,"^",3)=$P(QAOSTEMP,"^",3)+1 ; # REFERRED PEER
  1.  . I QAOSLEVL=QAOSFIND(11) S $P(QAOSTEMP,"^",4)=$P(QAOSTEMP,"^",4)+1
  1.  . I QAOSLEVL=QAOSFIND(12) S $P(QAOSTEMP,"^",5)=$P(QAOSTEMP,"^",5)+1
  1.  . I QAOSLEVL=QAOSFIND(13) S $P(QAOSTEMP,"^",6)=$P(QAOSTEMP,"^",6)+1
  1.  . Q
  1.  ;  OUTCOME PEER: PENDING
  1.  S QAOSS1=0
  1.  F  S QAOSS1=$O(^QA(741,QAOSD0,"REVR","B",QAOSPEER,QAOSS1)) Q:QAOSS1'>0  D
  1.  . S SERV=+$P($G(^QA(741,QAOSD0,"REVR",QAOSS1,0)),"^",10)
  1.  . Q:$G(SERV(SERV))  S SERV(SERV)=1
  1.  . S $P(QAOSTEMP,"^",3)=$P(QAOSTEMP,"^",3)+1 ; # REFERRED PEER
  1.  . S $P(QAOSTEMP,"^",7)=$P(QAOSTEMP,"^",7)+1 ; PEER: PENDING
  1.  . D PEND(2)
  1.  . Q
  1.  ;  # OCCUR REFERRED SYS PROB
  1.  F X=5,7,8,9 I QAOSFIND=QAOSFIND(X) D  Q
  1.  . S $P(QAOSTEMP,"^",8)=$P(QAOSTEMP,"^",8)+1
  1.  . Q
  1.  ;  # OCCUR REFERRED EQUIP PROB
  1.  F X=4,6,8,9 I QAOSFIND=QAOSFIND(X) D  Q
  1.  . S $P(QAOSTEMP,"^",9)=$P(QAOSTEMP,"^",9)+1
  1.  . Q
  1.  S ^UTILITY($J,"QAOSPSM",QAOSSTAT,QAOSSEQ)=QAOSTEMP
  1.  Q
  1. PEND(Y) ;  SAVE PENDING , PENDING TYPE (Y=1/2)
  1.  S QAOSDPT=$G(^DPT(+QAOSZERO,0)),QAOSSN=$P(QAOSDPT,"^",9)
  1.  S QAOSPAT=$S($P(QAOSDPT,"^")]"":$P(QAOSDPT,"^"),1:+QAOSZERO)
  1.  S QAOSDATE=+$P(QAOSZERO,"^",3),X=QAOSSN_"^"_Y
  1.  S ^UTILITY($J,"QAOSPEND",QAOSSCRN,QAOSDATE,QAOSPAT,QAOSD0)=X
  1.  Q