- 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
