BMCRL1 ; IHS/PHXAO/TMJ - PROCESS REFERRAL LIST ;
;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
;IHS/ITSC/FCJ ADDED TEST FOR BMCSORT="" WAS SET FOR TOT AND SUBTOT
; IN CANNED REPORTS ; ADDED VARS FOR COMMENTS SCREEN
; TEST FOR REF: PRIM, SEC OR BOTH AND TEST FOR CALL-INS ONLY
;
START ;
S (BMCBT,BMCBTH)=$H,BMCJOB=$J,BMCRCNT=0
D PROCESS,END
Q
;
PROCESS ;
S BMCREF=0 F S BMCREF=$O(^BMCREF(BMCREF)) Q:BMCREF'=+BMCREF D PROC
Q
;
END ;
S BMCET=$H
Q
PROC ;
K BMCSPEC
I BMCPTVS="R" S BMCRREC=^BMCREF(BMCREF,0),DFN=$P(BMCRREC,U,3)
I BMCPTVS="P" S DFN=BMCREF
I $D(^BMCRTMP(BMCRPT,11,191)),$P(BMCRREC,U,6)'="" Q ;TEST FOR CALL-INS
I '$D(^BMCRTMP(BMCRPT,11,150)),$P(BMCRREC,U,4)="N" Q
;4.0 IHS/ITSC/FCJ TEST FOR PRIM, SECONDARY OR BOTH......
I BMCTYPR="P",$P($G(^BMCREF(BMCREF,1)),U)'="" Q
I BMCTYPR="S",$P($G(^BMCREF(BMCREF,1)),U)="" Q
D SCREENS
Q:$D(BMCSKIP)
K BMCSRT,BMCPRNT S BMCCRIT=BMCSORT,BMCX=0
I BMCSORT'="" X:$D(^BMCTSORT(BMCSORT,4)) ^BMCTSORT(BMCSORT,4)
I '$D(BMCPRNT) D
. I BMCPTVS="R" S Y=$P(BMCRREC,U) S BMCPRNT=Y Q
. S BMCPRNT=$P(^DPT(DFN,0),U)
;BMCSRT -If Null you can enter value in each sort field in lister
S BMCSRT=BMCPRNT I BMCSRT="" S BMCSRT="NONE"
S ^XTMP("BMCRL",BMCJOB,BMCBTH,"DATA HITS",BMCSRT,BMCREF)="",BMCRCNT=BMCRCNT+1
NUMBER ;Numeric Output choice
I BMCCTYP="N" D
.I '$D(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS")) S ^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS")=0
.S $P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U)=$P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U)+1
.X ^BMCTSORT(BMCNSRT,1)
.Q:$G(X)=""
.S $P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U,6)=$P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U,6)+1
.S $P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U,2)=$P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U,2)+X
.S T=$P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U,2),C=$P(^("STATS"),U,6),M=T/C
.S $P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U,3)=M
.I $P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U,4)="" S $P(^("STATS"),U,4)=X
.I $P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U,4)>X S $P(^("STATS"),U,4)=X
.I X>$P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U,5) S $P(^("STATS"),U,5)=X
.Q:BMCSORT=6
.I '$D(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT)) S ^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT)=0
.S $P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U)=$P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U)+1
.X ^BMCTSORT(BMCNSRT,1)
.Q:$G(X)=""
.S $P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U,2)=$P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U,2)+X
.S $P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U,6)=$P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U,6)+1
.S T=$P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U,2),C=$P(^(BMCPRNT),U,6),M=T/C
.S $P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U,3)=M
.I $P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U,4)="" S $P(^(BMCPRNT),U,4)=X
.I $P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U,4)>X S $P(^(BMCPRNT),U,4)=X
.I X>$P(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U,5) S $P(^(BMCPRNT),U,5)=X
Q:'$D(DFN)!(DFN="") ;10.22.04 IHS/ITSC/FCJ
Q:$D(^XTMP("BMCRL",BMCJOB,BMCBTH,"PATIENTS",DFN))!($D(BMCSCNT))
S ^XTMP("BMCRL",BMCJOB,BMCBTH,"PATIENTS",DFN)="",BMCPTCT=BMCPTCT+1
Q
SCREENS ;
K BMCSKIP
S BMCI=0 F S BMCI=$O(^BMCRTMP(BMCRPT,11,BMCI)) Q:BMCI'=+BMCI!($D(BMCSKIP)) D
.I '$P(^BMCTSORT(BMCI,0),U,8) D SINGLE Q
.D MULT
S BMCI=""
Q
SINGLE ;
Q:BMCI=150 ;special stuff for inhouse
K X,BMCSPEC S X="",BMCX=0
X:$D(^BMCTSORT(BMCI,1)) ^(1)
I X="" S BMCSKIP="" Q
I '$D(BMCSPEC),'$D(^BMCRTMP(BMCRPT,11,BMCI,11,"B",X)) S BMCSKIP="" Q
Q
MULT ;
K BMCFOUN,BMCSKIP,BMCSPEC,X
S BMCX=0,X=""
S Y=0,Y1=BMCREF
X:$D(^BMCTSORT(BMCI,1)) ^BMCTSORT(BMCI,1)
I $O(X(""))="" S BMCSKIP="" Q
I '$D(BMCSPEC) S Y="" F S Y=$O(X(Y)) Q:Y="" I $D(^BMCRTMP(BMCRPT,11,BMCI,11,"B",Y)) S BMCFOUN="" Q
I $D(BMCSPEC),$G(X) S BMCFOUN=1 Q
S:'$D(BMCFOUN) BMCSKIP=""
Q
BMCRL1 ; IHS/PHXAO/TMJ - PROCESS REFERRAL LIST ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
+2 ;IHS/ITSC/FCJ ADDED TEST FOR BMCSORT="" WAS SET FOR TOT AND SUBTOT
+3 ; IN CANNED REPORTS ; ADDED VARS FOR COMMENTS SCREEN
+4 ; TEST FOR REF: PRIM, SEC OR BOTH AND TEST FOR CALL-INS ONLY
+5 ;
START ;
+1 SET (BMCBT,BMCBTH)=$HOROLOG
SET BMCJOB=$JOB
SET BMCRCNT=0
+2 DO PROCESS
DO END
+3 QUIT
+4 ;
PROCESS ;
+1 SET BMCREF=0
FOR
SET BMCREF=$ORDER(^BMCREF(BMCREF))
IF BMCREF'=+BMCREF
QUIT
DO PROC
+2 QUIT
+3 ;
END ;
+1 SET BMCET=$HOROLOG
+2 QUIT
PROC ;
+1 KILL BMCSPEC
+2 IF BMCPTVS="R"
SET BMCRREC=^BMCREF(BMCREF,0)
SET DFN=$PIECE(BMCRREC,U,3)
+3 IF BMCPTVS="P"
SET DFN=BMCREF
+4 ;TEST FOR CALL-INS
IF $DATA(^BMCRTMP(BMCRPT,11,191))
IF $PIECE(BMCRREC,U,6)'=""
QUIT
+5 IF '$DATA(^BMCRTMP(BMCRPT,11,150))
IF $PIECE(BMCRREC,U,4)="N"
QUIT
+6 ;4.0 IHS/ITSC/FCJ TEST FOR PRIM, SECONDARY OR BOTH......
+7 IF BMCTYPR="P"
IF $PIECE($GET(^BMCREF(BMCREF,1)),U)'=""
QUIT
+8 IF BMCTYPR="S"
IF $PIECE($GET(^BMCREF(BMCREF,1)),U)=""
QUIT
+9 DO SCREENS
+10 IF $DATA(BMCSKIP)
QUIT
+11 KILL BMCSRT,BMCPRNT
SET BMCCRIT=BMCSORT
SET BMCX=0
+12 IF BMCSORT'=""
IF $DATA(^BMCTSORT(BMCSORT,4))
XECUTE ^BMCTSORT(BMCSORT,4)
+13 IF '$DATA(BMCPRNT)
Begin DoDot:1
+14 IF BMCPTVS="R"
SET Y=$PIECE(BMCRREC,U)
SET BMCPRNT=Y
QUIT
+15 SET BMCPRNT=$PIECE(^DPT(DFN,0),U)
End DoDot:1
+16 ;BMCSRT -If Null you can enter value in each sort field in lister
+17 SET BMCSRT=BMCPRNT
IF BMCSRT=""
SET BMCSRT="NONE"
+18 SET ^XTMP("BMCRL",BMCJOB,BMCBTH,"DATA HITS",BMCSRT,BMCREF)=""
SET BMCRCNT=BMCRCNT+1
NUMBER ;Numeric Output choice
+1 IF BMCCTYP="N"
Begin DoDot:1
+2 IF '$DATA(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"))
SET ^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS")=0
+3 SET $PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U)=$PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U)+1
+4 XECUTE ^BMCTSORT(BMCNSRT,1)
+5 IF $GET(X)=""
QUIT
+6 SET $PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U,6)=$PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U,6)+1
+7 SET $PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U,2)=$PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U,2)+X
+8 SET T=$PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U,2)
SET C=$PIECE(^("STATS"),U,6)
SET M=T/C
+9 SET $PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U,3)=M
+10 IF $PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U,4)=""
SET $PIECE(^("STATS"),U,4)=X
+11 IF $PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U,4)>X
SET $PIECE(^("STATS"),U,4)=X
+12 IF X>$PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS"),U,5)
SET $PIECE(^("STATS"),U,5)=X
+13 IF BMCSORT=6
QUIT
+14 IF '$DATA(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT))
SET ^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT)=0
+15 SET $PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U)=$PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U)+1
+16 XECUTE ^BMCTSORT(BMCNSRT,1)
+17 IF $GET(X)=""
QUIT
+18 SET $PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U,2)=$PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U,2)+X
+19 SET $PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U,6)=$PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U,6)+1
+20 SET T=$PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U,2)
SET C=$PIECE(^(BMCPRNT),U,6)
SET M=T/C
+21 SET $PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U,3)=M
+22 IF $PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U,4)=""
SET $PIECE(^(BMCPRNT),U,4)=X
+23 IF $PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U,4)>X
SET $PIECE(^(BMCPRNT),U,4)=X
+24 IF X>$PIECE(^XTMP("BMCRL",BMCJOB,BMCBTH,"STATS",BMCSRT),U,5)
SET $PIECE(^(BMCPRNT),U,5)=X
End DoDot:1
+25 ;10.22.04 IHS/ITSC/FCJ
IF '$DATA(DFN)!(DFN="")
QUIT
+26 IF $DATA(^XTMP("BMCRL",BMCJOB,BMCBTH,"PATIENTS",DFN))!($DATA(BMCSCNT))
QUIT
+27 SET ^XTMP("BMCRL",BMCJOB,BMCBTH,"PATIENTS",DFN)=""
SET BMCPTCT=BMCPTCT+1
+28 QUIT
SCREENS ;
+1 KILL BMCSKIP
+2 SET BMCI=0
FOR
SET BMCI=$ORDER(^BMCRTMP(BMCRPT,11,BMCI))
IF BMCI'=+BMCI!($DATA(BMCSKIP))
QUIT
Begin DoDot:1
+3 IF '$PIECE(^BMCTSORT(BMCI,0),U,8)
DO SINGLE
QUIT
+4 DO MULT
End DoDot:1
+5 SET BMCI=""
+6 QUIT
SINGLE ;
+1 ;special stuff for inhouse
IF BMCI=150
QUIT
+2 KILL X,BMCSPEC
SET X=""
SET BMCX=0
+3 IF $DATA(^BMCTSORT(BMCI,1))
XECUTE ^(1)
+4 IF X=""
SET BMCSKIP=""
QUIT
+5 IF '$DATA(BMCSPEC)
IF '$DATA(^BMCRTMP(BMCRPT,11,BMCI,11,"B",X))
SET BMCSKIP=""
QUIT
+6 QUIT
MULT ;
+1 KILL BMCFOUN,BMCSKIP,BMCSPEC,X
+2 SET BMCX=0
SET X=""
+3 SET Y=0
SET Y1=BMCREF
+4 IF $DATA(^BMCTSORT(BMCI,1))
XECUTE ^BMCTSORT(BMCI,1)
+5 IF $ORDER(X(""))=""
SET BMCSKIP=""
QUIT
+6 IF '$DATA(BMCSPEC)
SET Y=""
FOR
SET Y=$ORDER(X(Y))
IF Y=""
QUIT
IF $DATA(^BMCRTMP(BMCRPT,11,BMCI,11,"B",Y))
SET BMCFOUN=""
QUIT
+7 IF $DATA(BMCSPEC)
IF $GET(X)
SET BMCFOUN=1
QUIT
+8 IF '$DATA(BMCFOUN)
SET BMCSKIP=""
+9 QUIT
