BMCSPD ; IHS/PHXAO/TMJ - display site parameters ; [ 09/27/2006 2:16 PM ]
;;4.0;REFERRED CARE INFO SYSTEM;**1,2,3**;JAN 09, 2006;Build 101
;4.0 IHS/OIT/FCJ ADDED FIELDS TO BE DISPLAYED
;4.0*1 2.14.06 IHS/OIT/FCJ ADDED FIELDS TO PRINT ADDRESS
;4.0*2 2.14.06 IHS/OIT/FCJ ADDED 2nd Ref POV and Mailman subject line
;4.0*2 2.14.06 IHS/OIT/FCJ ADDED Consult letter, Alert for Ref Phy and Prim Prov to display
;
;
EN1 ;
K BMCQUIT
W !!,"Display Referred Care Information System (RCIS) Site Parameters",!
S DIC="^BMCPARM(",DIC(0)="AEMQ" D ^DIC K DIC I Y=-1 W !!,"Goodbye" G XIT
S BMCPARM=+Y
S DIR(0)="SO^B:BROWSE Output on Screen;P:PRINT Output to Printer",DIR("A")="Do you want to",DIR("B")="B" K DA D ^DIR K DIR
G:$D(DIRUT) XIT
I Y="B" D BROWSE,XIT Q
S XBRP="PRINT^BMCSPD",XBRC="PROC^BMCSPD",XBRX="XIT^BMCSPD",XBNS="BMC"
D ^XBDBQUE
D XIT
Q
XIT ;EP
K BMCPARM,BMCX,BMCI,BMCPG,Y
Q
BROWSE ;
D VIEWR^XBLM("PRINT^BMCSPD","RCIS Site Parameter Display")
Q
PROC ;
Q
PRINT ;
S BMCPG=0
K BMCX,BMCI
W:$D(IOF) @IOF W !?30,"RCIS SITE PARAMETERS",!
F BMCI=.01:.01:.99 I $D(^DD(90001.31,BMCI)) S BMCX(BMCI)=$P(^DD(90001.31,BMCI,0),U)_U_$$VAL^XBDIQ1(90001.31,BMCPARM,BMCI)
;4.0*3 9.27.2007 IHS/OIT/FCJ FCJ Patch 2 changed 4104 to 4107 and patch 3 changed 4107 TO 4110 in next line New parameters added
F BMCI=4101:.01:4110 I $D(^DD(90001.31,BMCI)) S BMCX(BMCI)=$P(^DD(90001.31,BMCI,0),U)_U_$$VAL^XBDIQ1(90001.31,BMCPARM,BMCI) ;4.0*3 IHS/OIT/FCJ
F BMCI=1101:.01:1199 I $D(^DD(90001.31,BMCI)) S BMCX(BMCI)=$P(^DD(90001.31,BMCI,0),U)_U_$$VAL^XBDIQ1(90001.31,BMCPARM,BMCI)
F BMCI=201:.01:204 I $D(^DD(90001.31,BMCI)) S BMCX(BMCI)=$P(^DD(90001.31,BMCI,0),U)_U_$$VAL^XBDIQ1(90001.31,BMCPARM,BMCI) ;4.0*1 IHS/OIT/FCJ ADDED TO PRINT ADDRESS
S X=0 F S X=$O(BMCX(X)) Q:X'=+X!($D(BMCQUIT)) D
.I $Y>(IOSL-4) D FF Q:$D(BMCQUIT)
.S L=$L($P(BMCX(X),U)) W !?(37-$S(L>37:37,1:L)),$P(BMCX(X),U),":",?40,$P(BMCX(X),U,2)
.Q
K BMCX D ENP^XBDIQ1(90001.31,BMCPARM,1,"BMCX(","E")
I $Y>(IOSL-3) D FF Q:$D(BMCQUIT)
W !!,"HELP PROMPT FOR PRIORITY SYSTEM:"
S BMCI=0 F S BMCI=$O(BMCX(1,BMCI)) Q:BMCI'=+BMCI D
.I $Y>(IOSL-4) D FF Q:$D(BMCQUIT)
.W !,BMCX(1,BMCI)
.Q
HCDB ;
K BMCX D ENPM^XBDIQ1(90001.312101,DUZ(2)_",0",".01:.02","BMCX(")
I $D(BMCX) W !!,"HIGH COST DIAGNOSES BULLETINS: "
S BMCI=0 F S BMCI=$O(BMCX(BMCI)) Q:BMCI'=+BMCI D
.I $Y>(IOSL-4) D FF Q:$D(BMCQUIT)
.W !,"Person Receiving Bulletin: ",$G(BMCX(BMCI,.01))," Types: ",$G(BMCX(BMCI,.02))
.Q
HCPB ;
K BMCX D ENPM^XBDIQ1(90001.312201,DUZ(2)_",0",".01:.02","BMCX(")
I $D(BMCX) W !!,"HIGH COST PROCEDURES BULLETINS: "
S BMCI=0 F S BMCI=$O(BMCX(BMCI)) Q:BMCI'=+BMCI D
.I $Y>(IOSL-4) D FF Q:$D(BMCQUIT)
.W !,"Person Receiving Bulletin: ",$G(BMCX(BMCI,.01))," Types: ",$G(BMCX(BMCI,.02))
.Q
CP ;
K BMCX D ENPM^XBDIQ1(90001.312301,DUZ(2)_",0",".01:.02","BMCX(")
I $D(BMCX) W !!,"COSMETIC PROCEDURE BULLETINS: "
S BMCI=0 F S BMCI=$O(BMCX(BMCI)) Q:BMCI'=+BMCI D
.I $Y>(IOSL-4) D FF Q:$D(BMCQUIT)
.W !,"Person Receiving Bulletin: ",$G(BMCX(BMCI,.01))," Types: ",$G(BMCX(BMCI,.02))
.Q
EP ;
K BMCX D ENPM^XBDIQ1(90001.312401,DUZ(2)_",0",".01:.02","BMCX(")
I $D(BMCX) W !!,"EXPERIMENTAL PROCEDURE BULLETINS: "
S BMCI=0 F S BMCI=$O(BMCX(BMCI)) Q:BMCI'=+BMCI D
.I $Y>(IOSL-4) D FF Q:$D(BMCQUIT)
.W !,"Person Receiving Bulletin: ",$G(BMCX(BMCI,.01))," Types: ",$G(BMCX(BMCI,.02))
.Q
TPL ;
K BMCX D ENPM^XBDIQ1(90001.312501,DUZ(2)_",0",".01:.02","BMCX(")
I $D(BMCX) W !!,"THIRD PARTY LIABILITY BULLETINS: "
S BMCI=0 F S BMCI=$O(BMCX(BMCI)) Q:BMCI'=+BMCI D
.I $Y>(IOSL-4) D FF Q:$D(BMCQUIT)
.W !,"Person Receiving Bulletin: ",$G(BMCX(BMCI,.01))," Types: ",$G(BMCX(BMCI,.02))
.Q
SSTXT ; SITE-SPECIFIC TEXT FOR REFERRAL LETTERS
N BMCI1 F BMCI1=31:1:34 D
. K BMCX
. D ENP^XBDIQ1(90001.31,BMCPARM,BMCI1_"01","BMCX(","E")
. W:$D(^BMCPARM(BMCPARM,BMCI1)) !!,$P(^DD(90001.31,BMCI1_"01",0),U),":"
. S BMCI=0 F S BMCI=$O(BMCX(BMCI1_"01",BMCI)) Q:BMCI'=+BMCI D
.. I $Y>(IOSL-4) D FF Q:$D(BMCQUIT)
.. W !,BMCX(BMCI1_"01",BMCI)
.. Q
. Q
K BMCI1
Q:$E(IOST)'="C"
Q:$D(ZTQUEUED)
S DIR(0)="FO^1:1",DIR("A")="Press 'RETURN' to Continue" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
FF ;
NEW X
I $E(IOST)="C" S DIR(0)="E",DIR("A")="Press 'RETURN' to continue or '^' to exit" D ^DIR K DIR I $D(DIRUT) S BMCQUIT=1 Q
S BMCPG=BMCPG+1
W:$D(IOF) @IOF
W !?40,"RCIS SITE PARAMETERS Page ",BMCPG,!!
Q
BMCSPD ; IHS/PHXAO/TMJ - display site parameters ; [ 09/27/2006 2:16 PM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**1,2,3**;JAN 09, 2006;Build 101
+2 ;4.0 IHS/OIT/FCJ ADDED FIELDS TO BE DISPLAYED
+3 ;4.0*1 2.14.06 IHS/OIT/FCJ ADDED FIELDS TO PRINT ADDRESS
+4 ;4.0*2 2.14.06 IHS/OIT/FCJ ADDED 2nd Ref POV and Mailman subject line
+5 ;4.0*2 2.14.06 IHS/OIT/FCJ ADDED Consult letter, Alert for Ref Phy and Prim Prov to display
+6 ;
+7 ;
EN1 ;
+1 KILL BMCQUIT
+2 WRITE !!,"Display Referred Care Information System (RCIS) Site Parameters",!
+3 SET DIC="^BMCPARM("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
IF Y=-1
WRITE !!,"Goodbye"
GOTO XIT
+4 SET BMCPARM=+Y
+5 SET DIR(0)="SO^B:BROWSE Output on Screen;P:PRINT Output to Printer"
SET DIR("A")="Do you want to"
SET DIR("B")="B"
KILL DA
DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
GOTO XIT
+7 IF Y="B"
DO BROWSE
DO XIT
QUIT
+8 SET XBRP="PRINT^BMCSPD"
SET XBRC="PROC^BMCSPD"
SET XBRX="XIT^BMCSPD"
SET XBNS="BMC"
+9 DO ^XBDBQUE
+10 DO XIT
+11 QUIT
XIT ;EP
+1 KILL BMCPARM,BMCX,BMCI,BMCPG,Y
+2 QUIT
BROWSE ;
+1 DO VIEWR^XBLM("PRINT^BMCSPD","RCIS Site Parameter Display")
+2 QUIT
PROC ;
+1 QUIT
PRINT ;
+1 SET BMCPG=0
+2 KILL BMCX,BMCI
+3 IF $DATA(IOF)
WRITE @IOF
WRITE !?30,"RCIS SITE PARAMETERS",!
+4 FOR BMCI=.01:.01:.99
IF $DATA(^DD(90001.31,BMCI))
SET BMCX(BMCI)=$PIECE(^DD(90001.31,BMCI,0),U)_U_$$VAL^XBDIQ1(90001.31,BMCPARM,BMCI)
+5 ;4.0*3 9.27.2007 IHS/OIT/FCJ FCJ Patch 2 changed 4104 to 4107 and patch 3 changed 4107 TO 4110 in next line New parameters added
+6 ;4.0*3 IHS/OIT/FCJ
FOR BMCI=4101:.01:4110
IF $DATA(^DD(90001.31,BMCI))
SET BMCX(BMCI)=$PIECE(^DD(90001.31,BMCI,0),U)_U_$$VAL^XBDIQ1(90001.31,BMCPARM,BMCI)
+7 FOR BMCI=1101:.01:1199
IF $DATA(^DD(90001.31,BMCI))
SET BMCX(BMCI)=$PIECE(^DD(90001.31,BMCI,0),U)_U_$$VAL^XBDIQ1(90001.31,BMCPARM,BMCI)
+8 ;4.0*1 IHS/OIT/FCJ ADDED TO PRINT ADDRESS
FOR BMCI=201:.01:204
IF $DATA(^DD(90001.31,BMCI))
SET BMCX(BMCI)=$PIECE(^DD(90001.31,BMCI,0),U)_U_$$VAL^XBDIQ1(90001.31,BMCPARM,BMCI)
+9 SET X=0
FOR
SET X=$ORDER(BMCX(X))
IF X'=+X!($DATA(BMCQUIT))
QUIT
Begin DoDot:1
+10 IF $Y>(IOSL-4)
DO FF
IF $DATA(BMCQUIT)
QUIT
+11 SET L=$LENGTH($PIECE(BMCX(X),U))
WRITE !?(37-$SELECT(L>37:37,1:L)),$PIECE(BMCX(X),U),":",?40,$PIECE(BMCX(X),U,2)
+12 QUIT
End DoDot:1
+13 KILL BMCX
DO ENP^XBDIQ1(90001.31,BMCPARM,1,"BMCX(","E")
+14 IF $Y>(IOSL-3)
DO FF
IF $DATA(BMCQUIT)
QUIT
+15 WRITE !!,"HELP PROMPT FOR PRIORITY SYSTEM:"
+16 SET BMCI=0
FOR
SET BMCI=$ORDER(BMCX(1,BMCI))
IF BMCI'=+BMCI
QUIT
Begin DoDot:1
+17 IF $Y>(IOSL-4)
DO FF
IF $DATA(BMCQUIT)
QUIT
+18 WRITE !,BMCX(1,BMCI)
+19 QUIT
End DoDot:1
HCDB ;
+1 KILL BMCX
DO ENPM^XBDIQ1(90001.312101,DUZ(2)_",0",".01:.02","BMCX(")
+2 IF $DATA(BMCX)
WRITE !!,"HIGH COST DIAGNOSES BULLETINS: "
+3 SET BMCI=0
FOR
SET BMCI=$ORDER(BMCX(BMCI))
IF BMCI'=+BMCI
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-4)
DO FF
IF $DATA(BMCQUIT)
QUIT
+5 WRITE !,"Person Receiving Bulletin: ",$GET(BMCX(BMCI,.01))," Types: ",$GET(BMCX(BMCI,.02))
+6 QUIT
End DoDot:1
HCPB ;
+1 KILL BMCX
DO ENPM^XBDIQ1(90001.312201,DUZ(2)_",0",".01:.02","BMCX(")
+2 IF $DATA(BMCX)
WRITE !!,"HIGH COST PROCEDURES BULLETINS: "
+3 SET BMCI=0
FOR
SET BMCI=$ORDER(BMCX(BMCI))
IF BMCI'=+BMCI
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-4)
DO FF
IF $DATA(BMCQUIT)
QUIT
+5 WRITE !,"Person Receiving Bulletin: ",$GET(BMCX(BMCI,.01))," Types: ",$GET(BMCX(BMCI,.02))
+6 QUIT
End DoDot:1
CP ;
+1 KILL BMCX
DO ENPM^XBDIQ1(90001.312301,DUZ(2)_",0",".01:.02","BMCX(")
+2 IF $DATA(BMCX)
WRITE !!,"COSMETIC PROCEDURE BULLETINS: "
+3 SET BMCI=0
FOR
SET BMCI=$ORDER(BMCX(BMCI))
IF BMCI'=+BMCI
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-4)
DO FF
IF $DATA(BMCQUIT)
QUIT
+5 WRITE !,"Person Receiving Bulletin: ",$GET(BMCX(BMCI,.01))," Types: ",$GET(BMCX(BMCI,.02))
+6 QUIT
End DoDot:1
EP ;
+1 KILL BMCX
DO ENPM^XBDIQ1(90001.312401,DUZ(2)_",0",".01:.02","BMCX(")
+2 IF $DATA(BMCX)
WRITE !!,"EXPERIMENTAL PROCEDURE BULLETINS: "
+3 SET BMCI=0
FOR
SET BMCI=$ORDER(BMCX(BMCI))
IF BMCI'=+BMCI
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-4)
DO FF
IF $DATA(BMCQUIT)
QUIT
+5 WRITE !,"Person Receiving Bulletin: ",$GET(BMCX(BMCI,.01))," Types: ",$GET(BMCX(BMCI,.02))
+6 QUIT
End DoDot:1
TPL ;
+1 KILL BMCX
DO ENPM^XBDIQ1(90001.312501,DUZ(2)_",0",".01:.02","BMCX(")
+2 IF $DATA(BMCX)
WRITE !!,"THIRD PARTY LIABILITY BULLETINS: "
+3 SET BMCI=0
FOR
SET BMCI=$ORDER(BMCX(BMCI))
IF BMCI'=+BMCI
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-4)
DO FF
IF $DATA(BMCQUIT)
QUIT
+5 WRITE !,"Person Receiving Bulletin: ",$GET(BMCX(BMCI,.01))," Types: ",$GET(BMCX(BMCI,.02))
+6 QUIT
End DoDot:1
SSTXT ; SITE-SPECIFIC TEXT FOR REFERRAL LETTERS
+1 NEW BMCI1
FOR BMCI1=31:1:34
Begin DoDot:1
+2 KILL BMCX
+3 DO ENP^XBDIQ1(90001.31,BMCPARM,BMCI1_"01","BMCX(","E")
+4 IF $DATA(^BMCPARM(BMCPARM,BMCI1))
WRITE !!,$PIECE(^DD(90001.31,BMCI1_"01",0),U),":"
+5 SET BMCI=0
FOR
SET BMCI=$ORDER(BMCX(BMCI1_"01",BMCI))
IF BMCI'=+BMCI
QUIT
Begin DoDot:2
+6 IF $Y>(IOSL-4)
DO FF
IF $DATA(BMCQUIT)
QUIT
+7 WRITE !,BMCX(BMCI1_"01",BMCI)
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 KILL BMCI1
+11 IF $EXTRACT(IOST)'="C"
QUIT
+12 IF $DATA(ZTQUEUED)
QUIT
+13 SET DIR(0)="FO^1:1"
SET DIR("A")="Press 'RETURN' to Continue"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+14 QUIT
FF ;
+1 NEW X
+2 IF $EXTRACT(IOST)="C"
SET DIR(0)="E"
SET DIR("A")="Press 'RETURN' to continue or '^' to exit"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET BMCQUIT=1
QUIT
+3 SET BMCPG=BMCPG+1
+4 IF $DATA(IOF)
WRITE @IOF
+5 WRITE !?40,"RCIS SITE PARAMETERS Page ",BMCPG,!!
+6 QUIT
