BCHUTIL ; IHS/CMI/LAB - UTILITIES ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;
XTMP(N,T) ;EP
I $G(N)="" Q
S ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_U_DT_U_T
Q
UNREQ ;EP - CALLED FROM SCREENMAN
NEW BCHF
F BCHF=3,4,5 D REQ^DDSUTL(BCHF,2,"ENTER CHR DATA",0)
Q
PPINI(REC) ;EP
NEW X,Y,BCHX,BCHY,DIQ,DR,DA,BCHG,BCHINI
S BCHY=$P(^BCHR(REC,0),U,3)
I 'BCHY S BCHINI="???" Q BCHINI
S DA=BCHY,DIC=200,DR=1,DIQ="BCHINI",DIQ(0)="I"
D EN^DIQ1
S BCHINI=$G(BCHINI(200,BCHY,1,"I"))
S:BCHINI="" BCHINI="???"
Q BCHINI
PPNAME(REC) ;EP
NEW X,Y,BCHX,BCHY,DIQ,DR,DA,BCHG,BCHNAME
S BCHY=$P(^BCHR(REC,0),U,3)
I '$D(BCHY) S BCHNAME="???" Q BCHNAME
S BCHNAME=$P(^VA(200,BCHY,0),U)
S:BCHNAME="" BCHNAME="???"
Q BCHNAME
PPINT(REC) ;
NEW X,Y,BCHX,DIQ,DR,DA,BCHG,BCHY
S BCHY=$P(^BCHR(REC,0),U,3)
I '$D(BCHY) S BCHY="???" Q BCHY
Q BCHY
PPAFFL(REC,FORM) ;EP - get pp affiliation internal or external
NEW X,Y,BCHX,BCHY,DIQ,DR,DA,BCHG,BCHAFFL
S BCHY=$P(^BCHR(REC,0),U,3)
I 'BCHY S BCHAFFL="?" Q BCHAFFL
I '$D(^VA(200,BCHY)) S BCHAFFL="?" Q BCHAFFL
S DA=BCHY,DIC=200,DR=9999999.01,DIQ="BCHAFFL" S:$G(FORM)="I" DIQ(0)="I"
D EN^DIQ1
S BCHAFFL=$S($G(FORM)="I":BCHAFFL(200,BCHY,9999999.01,"I"),1:BCHAFFL(200,BCHY,"9999999.01"))
S:BCHAFFL="" BCHAFFL="?"
Q BCHAFFL
PPCLS(REC,FORM) ;EP
NEW X,Y,BCHX,BCHY,DIQ,DR,DA,BCHG,BCHCLS
S BCHY=$P(^BCHR(REC,0),U,3)
I 'BCHY S BCHCLS="???" Q BCHCLS
S DA=BCHY,DIC=200,DR=53.5,DIQ="BCHCLS" S:$G(FORM)="I" DIQ(0)="I"
D EN^DIQ1
S BCHCLS=$S($G(FORM)="I":$G(BCHCLS(200,BCHY,53.5,"I")),1:$G(BCHCLS(200,BCHY,"53.5")))
S:BCHCLS="" BCHCLS="???"
Q BCHCLS
PPCLSC(REC) ;EP GET PRIMARY PROVIDER CLASS CODE
NEW X,Y,CODE,DIC,DR,DA,DIQ,CLS
S CLS=$$PPCLS^BCHUTIL(REC,"I")
I CLS="???" S CODE="???" Q CODE
S DIC=7,DR="9999999.01",DA=CLS,DIQ="CODE"
D EN^DIQ1
S CODE=CODE(7,CLS,"9999999.01")
S:CODE="" CODE="???"
Q CODE
CALLDIE ;EP
Q:'$D(DA)
Q:'$D(DIE)
Q:'$D(DR)
D ^DIE
K DIE,DIC,DR,DA,D0,D,D1,DO,%X,%Y,X,A,Z,DIU,DIV,DIY,DIW,DIADD,DLAYGO,%,%E,%D,%W,DI,DIFLD,DIG,DIH,DK,DL,DISYS
Q
PROVCLC(PROV) ;get provider class code
NEW CODE,A
S CODE=""
I 'PROV Q CODE
S A=$P($G(^VA(200,PROV,"PS")),U,5)
I A="" Q CODE
S CODE=$P($G(^DIC(7,A,9999999)),U)
Q CODE
CANNEDN() ;EP - return canned narrative
NEW BCHX
;*****CALLED FROM SCREENMAN
S BCHX=$$GET^DDSVAL(90002.01,.DA,.04,"","I") I BCHX,$P($G(^BCHTSERV(BCHX,0)),U,4) D HLP^DDSUTL("You must type in a narrative for those services that pass to PCC") Q ""
I $$GET^DDSVAL(90002.01,.DA,.01,"","I")="" Q "<???>"
I $$GET^DDSVAL(90002.01,.DA,.04,"","I")="" Q $P(^BCHTPROB($$GET^DDSVAL(90002.01,.DA,.01,"","I"),0),U)
Q $E($P(^BCHTPROB($$GET^DDSVAL(90002.01,.DA,.01,"","I"),0),U)_":"_$P(^BCHTSERV($$GET^DDSVAL(90002.01,.DA,.04,"","I"),0),U),1,80)
UPDPCC ;EP - called when pcc adds a visit
Q:'$D(BCHEV) ;quit if not initiated by chr
Q:'$G(BCHEV("CHR IEN")) ;quit if don't know chr record ien
Q:'$D(BCHV) ;quit if no pcc data passed back
S DIE="^BCHR(",DA=BCHEV("CHR IEN"),DR=".15////"_BCHV("VISIT","9000010") D CALLDIE
K Y,DA,DR,DIE
S BCHX=0 F S BCHX=$O(BCHV("VFILES",BCHX)) Q:BCHX'=+BCHX D
.S BCHY=0 F S BCHY=$O(BCHV("VFILES",BCHX,BCHY)) Q:BCHY'=+BCHY D
..S DA=BCHEV("CHR IEN"),DR="3101///""`"_BCHX_"""",DIE="^BCHR("
..S DR(2,90002.03101)=".02////"_BCHY
..D CALLDIE
..K DIE,DA,DR,Y,X
..Q
.Q
K BCHX,BCHY
Q
NARRPOST ;EP
NEW BCHX
I BCHWTD="Y",X="" S BCHWTD="N"
I BCHWTD="Y",X]"" S DDSBR=5 Q
I X]"",BCHWTD="N" S DDACT="CL" Q
S BCHX=X
I BCHX="" S BCHX=$$CANNEDN^BCHUTIL() D:BCHX]"" PUT^DDSVAL(DIE,.DA,.06,BCHX,"","E")
I BCHX="" S DDSBR=2
;S DDACT="CL"
Q
SC(Y) ;EP - called from input transform
I $G(BCHPNP)=""!($G(BCHPNP)="N") Q 1
I BCHPNP="P",$P(^BCHTSERV(Y,0),U,6) Q 1
I BCHPNP="P",'$P(^BCHTSERV(Y,0),U,6) Q 0
Q 1
;
PR(Y) ;EP - called from input transform
;I $G(BCHPNP)=""!($G(BCHPNP)="N") Q 1
I $G(BCHPNP)="P",$P(^BCHTPROB(Y,0),U,2)="AM" Q 0
I $G(BCHPNP)="P",$P(^BCHTPROB(Y,0),U,2)="LT" Q 0
Q 1
CHKCF ;EP - called from screenman screen
NEW Z
S Z=$$GET^DDSVAL(DIE,DA,.01,,"I")
S Z=$P(^BCHTPROB(Z,0),U,2)
I Z="HB"!(Z="LP") D
.Q:$P(^BCHTSERV(BCHSERV,0),U,3)="CF"
.Q:$P(^BCHTSERV(BCHSERV,0),U,3)="IT"
.D HLP^DDSUTL("For Problem Codes HB and LP you can only use a Service Code of CF or IT.") S BCHQ=1
Q
;
SETDEFNX(R) ;EP - called from screenman screen
I '$G(R) Q ""
NEW X,Y,G,Z
S G=1
I $G(BCHPNP)="P" Q 1
I $G(BCHPNP)="N" Q 0
S X=0 F S X=$O(^BCHRPROB("AD",R,X)) Q:X'=+X D
.S Y=$P(^BCHRPROB(X,0),U,1)
.I Y S Y=$P(^BCHTPROB(Y,0),U,2)
.I Y="AM" S G=0 Q
.I Y="LT" S G=0 Q
.I Y["-" S G=0 Q
.S Z=$$GET^DDSVAL(90002.01,X,.04,,"I")
.I Z S Y=$P(^BCHTSERV(Z,0),U,3)
.I Y="LT" S G=0 Q
.I Y="AM" S G=0 Q
.I Y="NF" S G=0 Q
.I Y="OT" S G=0 Q
.I Y="CD" S G=0 Q
.Q
Q G
NR ;EP - unrequire .05,spec,city,state
D REQ^DDSUTL("SPECIALTY",1,1.2,0)
D REQ^DDSUTL("CITY",1,1.2,0)
D REQ^DDSUTL("STATE",1,1.2,0)
Q
SERCS ;EP - require spec,city,state
I X="" D
.D REQ^DDSUTL("SPECIALTY",,,1)
.D REQ^DDSUTL("CITY",,,1)
.D REQ^DDSUTL("STATE",,,1)
I X]"" D
.D REQ^DDSUTL("SPECIALTY",,,0)
.D REQ^DDSUTL("CITY",,,0)
.D REQ^DDSUTL("STATE",,,0)
Q
SETDEFTT(R) ;EP - called from screenman screen
I '$G(R) Q ""
NEW X,Y,G,Z
S G=""
I $G(BCHPNP)="P" Q ""
S X=0 F S X=$O(^BCHRPROB("AD",R,X)) Q:X'=+X D
.S Y=$P(^BCHRPROB(X,0),U,1)
.I Y S Y=$P(^BCHTPROB(Y,0),U,2)
.;I Y="AM" S G=0 Q
.I Y="LT" S G=0 Q
.;I Y["-" S G=0 Q
.S Z=$$GET^DDSVAL(90002.01,X,.04,,"I")
.I Z S Y=$P(^BCHTSERV(Z,0),U,3)
.I Y="LT" S G=0 Q
.;I Y="AM" S G=0 Q
.;I Y="NF" S G=0 Q
.;I Y="OT" S G=0 Q
.;I Y="CD" S G=0 Q
.Q
Q G
SETDEFAL(R) ;EP - called from screenman screen
I '$G(R) Q ""
NEW X,Y,G,Z
S G=""
S X=0 F S X=$O(^BCHRPROB("AD",R,X)) Q:X'=+X D
.S Y=$P(^BCHRPROB(X,0),U,1)
.I Y S Y=$P(^BCHTPROB(Y,0),U,2)
.;I Y="AM" S G=0 Q
.I Y="LT" S G="NONE" Q
.;I Y["-" S G=0 Q
.S Z=$$GET^DDSVAL(90002.01,X,.04,,"I")
.I Z S Y=$P(^BCHTSERV(Z,0),U,3)
.I Y="LT" S G="NONE" Q
.;I Y="AM" S G=0 Q
.;I Y="NF" S G=0 Q
.I Y="OT" S G="NONE" Q
.Q
I G]"" Q $O(^BCHTACTL("B",G,0))
Q ""
SETDEFNS ;
NEW %
S %=$$GET^DDSVAL("^BCHR(",BCHR,.12)
;I %]"" Q
NEW G S G=$$SETDEFNX(BCHR)
I G]"" D PUT^DDSVAL("^BCHR(",BCHR,.12,G,,"I")
;NOW SET DEFAULT ACTIVITY LOCATION
NEW G S G=$$SETDEFAL(BCHR)
I G]"" D PUT^DDSVAL("^BCHR(",BCHR,.06,G,,"E")
;NOW SET DEFAULT TRAVEL TIME
S %=$$GET^DDSVAL("^BCHR(",BCHR,.11)
;I %]"" Q
NEW G S G=$$SETDEFTT(BCHR)
I G]"" D PUT^DDSVAL("^BCHR(",BCHR,.11,G,,"I")
Q
SETNAR ;EP
Q:X=""
D PUT^DDSVAL(DIE,.DA,.06,$P(^BCHTCNAR(X,0),U,1),"","E")
Q
SETDICS(PC,SC) ;EP
NEW PCSC,SCE
S SC=$G(SC)
I SC S SCE=$P(^BCHTSERV(SC,0),U,3)
S PC=$G(PC)
I PC S PC=$P(^BCHTPROB(PC,0),U,2)
S PCSC=PC_"-"_SCE
I $D(^BCHTCNAR(Y,11,"B",SC))!($D(^BCHTSERV(Y,12,"B",PCSC))) Q 1
Q 0
GETNARRS(PC,SC) ;
K BCHCOUNT,BCHCANNN
K ^BCHRPROB(DA,81)
NEW PCSC,SCE,C,X,PCN,V,N,Z,BCHO
S SCE=""
S C=0
S SC=$G(SC)
I 'SC Q
I SC S SCE=$P(^BCHTSERV(SC,0),U,3)
S PC=$G(PC)
I 'PC Q
S PCN=""
I PC S PCN=$P(^BCHTPROB(PC,0),U,1),PC=$P(^BCHTPROB(PC,0),U,2)
S PCSC=PC_"-"_SCE
;
S O=0 F S O=$O(^BCHTCNAR("ACOMB",PCSC,O)) Q:O'=+O D
.S X=0 F S X=$O(^BCHTCNAR("ACOMB",PCSC,O,X)) Q:X'=+X D
..I $G(BCHPNP)]"" Q:$P(^BCHTCNAR(X,0),U,2)'=BCHPNP
..I $G(BCHPNP)="" S V=$P(^BCHPROB(DA,0),U,3),N=$P(^BCHR(V,0),U,12) I N'=1,$P(^BCHTCNAR(X,0),U,2)'="N" Q
..I $G(BCHPNP)="" S V=$P(^BCHPROB(DA,0),U,3),N=$P(^BCHR(V,0),U,12) I N=1,$P(^BCHTCNAR(X,0),U,2)'="P" Q
..S Z=$$VAL^XBDIQ1(90002.59,X,.01)
..I Z["DX-" S Z=Z_PC ;$P(Z,"HPC",1)_PCN_$P(Z,"HPC",2)
..S C=C+1,BCHCANNN(O)=O_U_Z_""_U_X
I $D(BCHCANNN) G SET
;NOW CHECK SC
S O=0 F S O=$O(^BCHTCNAR("ASCO",SCE,O)) Q:O'=+O D
.S X=0 F S X=$O(^BCHTCNAR("ASCO",SCE,O,X)) Q:X'=+X D
..I $G(BCHPNP)]"" Q:$P(^BCHTCNAR(X,0),U,2)'=BCHPNP
..I $G(BCHPNP)="" S V=$P(^BCHPROB(DA,0),U,3),N=$P(^BCHR(V,0),U,12) I N'=1,$P(^BCHTCNAR(X,0),U,2)'="N" Q
..I $G(BCHPNP)="" S V=$P(^BCHPROB(DA,0),U,3),N=$P(^BCHR(V,0),U,12) I N=1,$P(^BCHTCNAR(X,0),U,2)'="P" Q
..S Z=$$VAL^XBDIQ1(90002.59,X,.01)
..I Z["DX-" S Z=Z_PC
..S C=C+1,BCHCANNN(O)=O_U_Z_""_U_X
I $D(BCHCANNN) D SET
Q
SET ;
NEW X,C,Y
S Y=0
S C=0 F S C=$O(BCHCANNN(C)) Q:C'=+C D
.S ^BCHRPROB(DA,81,$P(BCHCANNN(C),U,1),0)=$P(BCHCANNN(C),U,1)_U_$P(BCHCANNN(C),U,2)
.S ^BCHRPROB(DA,81,"B",$P(BCHCANNN(C),U,1),$P(BCHCANNN(C),U,1))=""
.S ^BCHRPROB(DA,81,0)="^90002.0181A^"_$P(BCHCANNN(C),U,1)_"^"_C
.S Y=Y+1
.S BCHCOUNT=Y
Q
N1 ;
I $G(BCHCANNN(1))="" S Y="" Q
S Y=$P($G(BCHCANNN(1)),U,1)_". "_$P($G(BCHCANNN(1)),U,2)
Q
N2 ;
I $G(BCHCANNN(2))="" S Y="" Q
S Y=$P($G(BCHCANNN(2)),U,1)_". "_$P($G(BCHCANNN(2)),U,2)
Q
N3 ;
I $G(BCHCANNN(3))="" S Y="" Q
S Y=$P($G(BCHCANNN(3)),U,1)_". "_$P($G(BCHCANNN(3)),U,2)
Q
N4 ;
I $G(BCHCANNN(4))="" S Y="" Q
S Y=$P($G(BCHCANNN(4)),U,1)_". "_$P($G(BCHCANNN(4)),U,2)
Q
N5 ;
I $G(BCHCANNN(5))="" S Y="" Q
S Y=$P($G(BCHCANNN(5)),U,1)_". "_$P($G(BCHCANNN(5)),U,2)
Q
N6 ;
I $G(BCHCANNN(6))="" S Y="" Q
S Y=$P($G(BCHCANNN(6)),U,1)_". "_$P($G(BCHCANNN(6)),U,2)
Q
SETCNAR ;EP - called from canned narrative block
NEW BCHX,BCHY,BCHZ
S BCHY=""
S BCHX=0 F S BCHX=$O(^BCHRPROB(DA(1),92,BCHX)) Q:BCHX'=+BCHX D
.I BCHY]"" S BCHY=BCHY_". "
.S BCHY=BCHY_$P($G(BCHCANNN($P(^BCHRPROB(DA(1),92,BCHX,0),U,1))),U,2)
I BCHY]"" S BCHY=BCHY_"" D PUT^DDSVAL(90002.01,DA(1),.06,$E(BCHY,1,158),,"E")
Q
NARRPRE ;EP
I BCHWTD="Y",$$GET^DDSVAL(DIE,DA,.06,,"I")]"" S DDSBR=5 Q
D HLP^DDSUTL("For services PC, HE, CF, CM, MP, EC and HS you must type a narrative.")
Q
ADDNARR ;EP
NEW BCHX,BCHY
I X="" Q
S BCHX=$$GET^DDSVAL(DIE,DA,.06,,"E")
S BCHY=$$GET^DDSVAL(DIE,DA,1101,,"E")
S BCHX=BCHX_" "_BCHY
D PUT^DDSVAL(DIE,DA,.06,BCHX,,"E")
D PUT^DDSVAL(DIE,DA,1101,"",,"I")
Q
GETNARRG(PC,SC) ;
K BCHCOUNT,BCHCANNN
K ^BCHRGAS(DA,81)
NEW PCSC,SCE,C,X,PCN,V,N,Z
S C=0
S SC=$G(SC)
I 'SC Q
S SCE=""
I SC S SCE=$P(^BCHTSERV(SC,0),U,3)
S PC=$G(PC)
I 'PC Q
S PCN=""
I PC S PCN=$P(^BCHTPROB(PC,0),U,1),PC=$P(^BCHTPROB(PC,0),U,2)
S PCSC=PC_"-"_SCE
;
S O=0 F S O=$O(^BCHTCNAR("ACOMB",PCSC,O)) Q:O'=+O D
.S X=0 F S X=$O(^BCHTCNAR("ACOMB",PCSC,O,X)) Q:X'=+X D
..Q:$P(^BCHTCNAR(X,0),U,2)'="G"
..S Z=$$VAL^XBDIQ1(90002.59,X,.01)
..I Z["DX-" S Z=Z_PC ;_$P(Z,"HPC",2)
..S C=C+1,BCHCANNN(O)=O_U_Z_""_U_X
I $D(BCHCANNN) G SETG
;NOW CHECK SC
S O=0 F S O=$O(^BCHTCNAR("ASCO",SCE,O)) Q:O'=+O D
.S X=0 F S X=$O(^BCHTCNAR("ASCO",SCE,O,X)) Q:X'=+X D
..Q:$P(^BCHTCNAR(X,0),U,2)'="G"
..S C=C+1,BCHCANNN(O)=O_U_$$VAL^XBDIQ1(90002.59,X,.01)_""_U_X
I $D(BCHCANNN) D SETG
Q
SETG ;
NEW X,C,Y
S Y=0
S C=0 F S C=$O(BCHCANNN(C)) Q:C'=+C D
.S ^BCHRGAS(DA,81,C,0)=C_U_$P(BCHCANNN(C),U,2)
.S ^BCHRGAS(DA,81,"B",C,C)=""
.S ^BCHRGAS(DA,81,0)="^90002.9881A^"_C_"^"_C
.S Y=Y+1
.S BCHCOUNT=Y
Q
;
NARRPREG ;EP
I BCHWTD="Y",$$GET^DDSVAL(DIE,DA,.06,,"I")]"" S DDSBR=5 Q
D HLP^DDSUTL("For services PC, HE, CF, CM, MP, EC and HS you must type a narrative.")
Q
;
NARRPOSG ;EP
NEW BCHX
I BCHWTD="Y",X="" S BCHWTD="N"
I BCHWTD="Y",X]"" S DDSBR=5 Q
I X]"",BCHWTD="N" S DDACT="CL" Q
S BCHX=X
I BCHX="" S BCHX=$$CANNEDNG^BCHUTIL() D:BCHX]"" PUT^DDSVAL(DIE,.DA,.06,BCHX,"","E")
I BCHX="" S DDSBR=2
;S DDACT="CL"
Q
;
CANNEDNG() ;EP - return canned narrative
NEW BCHX
;*****CALLED FROM SCREENMAN
S BCHX=$$GET^DDSVAL(90002.98,.DA,.04,"","I") I BCHX,$P($G(^BCHTSERV(BCHX,0)),U,4) D HLP^DDSUTL("You must type in a narrative for those services that pass to PCC") Q ""
I $$GET^DDSVAL(90002.98,.DA,.01,"","I")="" Q "<???>"
I $$GET^DDSVAL(90002.98,.DA,.04,"","I")="" Q $P(^BCHTPROB($$GET^DDSVAL(90002.01,.DA,.01,"","I"),0),U)
Q $E($P(^BCHTPROB($$GET^DDSVAL(90002.98,.DA,.01,"","I"),0),U)_":"_$P(^BCHTSERV($$GET^DDSVAL(90002.98,.DA,.04,"","I"),0),U),1,80)
;
ADDNARRG ;EP
NEW BCHX,BCHY
I X="" Q
S BCHX=$$GET^DDSVAL(DIE,DA,.06,,"E")
S BCHY=$$GET^DDSVAL(DIE,DA,1101,,"E")
S BCHX=BCHX_" "_BCHY
D PUT^DDSVAL(DIE,DA,.06,BCHX,,"E")
D PUT^DDSVAL(DIE,DA,1101,"",,"I")
Q
SETGNAR ;EP - called from canned narrative block
NEW BCHX,BCHY,BCHZ
S BCHY=""
S BCHX=0 F S BCHX=$O(^BCHRGAS(DA(1),92,BCHX)) Q:BCHX'=+BCHX D
.I BCHY]"" S BCHY=BCHY_". "
.S BCHY=BCHY_$P($G(BCHCANNN($P(^BCHRGAS(DA(1),92,BCHX,0),U,1))),U,2)
I BCHY]"" S BCHY=BCHY_"" D PUT^DDSVAL(90002.98,DA(1),.06,$E(BCHY,1,158),,"E")
Q
HELPREF ;EP - called from dd field 8902
NEW BCHX,BCHY,BCHZ
D EN^DDIOL("Enter a list of Referral Types separated by commas. You can")
D EN^DDIOL("enter the numbers or the name of the referral type in the list.")
D EN^DDIOL("Examples: 1,5 or 3 or MEDICAL,NURSING or MD,NR ")
S BCHX="" F S BCHX=$O(^BCHTREF("C",BCHX)) Q:BCHX="" D
.S BCHY=$O(^BCHTREF("C",BCHX,0))
.S BCHZ=$$VAL^XBDIQ1(90002.52,BCHY,.01),$E(BCHZ,25)=$$VAL^XBDIQ1(90002.52,BCHY,.02),$E(BCHZ,30)=$$VAL^XBDIQ1(90002.52,BCHY,.03)
.D EN^DDIOL(BCHZ)
.Q
Q
REFIT ;EP
NEW A,B,C,D,E,F,S
;input transform for referral range
I X?1N,$D(^BCHTREF("C",X)) Q
I X?1A.E D FTR Q
;GET THE COMMA PIECES
;STRIP SPACES
S S=X
S (S,X)=$$STRIP^XLFSTR(X," ")
F A=1:1 S B=$P(S,",",A) Q:B=""!('$D(X)) D
.I '$D(^BCHTREF("C",B)) K X Q
Q
FTR ;
;PARSE AND CHECK EACH ELEMENT
;GET THE COMMA PIECES
;STRIP SPACES
S S=X
S (S,C)=X ;$$STRIP^XLFSTR(X,", ")
F A=1:1 S B=$P(S,",",A) Q:B=""!('$D(C)) D
.S B=$$SB(B) S X=B,DIC="^BCHTREF(",DIC(0)="M" D ^DIC I Y=-1 K C Q
I '$D(C) K X Q
S X=S
Q
SB(X) ;EP - Strip leading and trailing blanks from X.
X ^DD("FUNC",$O(^DD("FUNC","B","STRIPBLANKS",0)),1)
Q X
FILEREF ;EP
K ^BCHR(BCHR,BCHNODE)
NEW BCHX,BCHY,BCHA,BCHB,BCHC,BCHS,BCHFULL
S BCHFULL=""
;input transform for referral range
S BCHC=0
I X?1N,$D(^BCHTREF("C",X)) S BCHX=$O(^BCHTREF("C",X,0)) D SETREF D REFRESH^DDSUTL Q
I X?1A.E D FTRREF D REFRESH^DDSUTL Q
;GET THE COMMA PIECES
;STRIP SPACES
S BCHS=X
S (BCHS)=$$STRIP^XLFSTR(X," ")
F BCHA=1:1 S BCHB=$P(BCHS,",",BCHA) Q:BCHB="" D
.S BCHX=$O(^BCHTREF("C",BCHB,0)) D SETREF
D REFRESH^DDSUTL
Q
FTRREF ;
;PARSE AND CHECK EACH ELEMENT
;GET THE COMMA PIECES
;STRIP SPACES
S BCHY=X
NEW X,Y
F BCHA=1:1 S BCHB=$P(BCHY,",",BCHA) Q:BCHB="" D
.S BCHB=$$SB(BCHB) S X=BCHB,DIC="^BCHTREF(",DIC(0)="M" D ^DIC I Y=-1 Q
.S BCHX=+Y D SETREF
Q
SETREF ;
SET1 ;
S BCHC=BCHC+1
S ^BCHR(BCHR,BCHNODE,BCHC,0)=BCHX
S ^BCHR(BCHR,BCHNODE,"B",BCHX,BCHC)=""
S ^BCHR(BCHR,BCHNODE,0)="^90002.1"_BCHNODE_"PA^"_BCHC_"^"_BCHC
I BCHFULL]"" S BCHFULL=BCHFULL_", "
S BCHFULL=BCHFULL_$P(^BCHTREF(BCHX,0),U,1)
;S $P(^BCHR(BCHR,86),U,$S(BCHNODE=41:1,1:2))=BCHFULL
S F=$S(BCHNODE=41:8601,1:8602)
D PUT^DDSVAL("^BCHR(",BCHR,F,BCHFULL,,"E")
Q
BCHUTIL ; IHS/CMI/LAB - UTILITIES ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;
XTMP(N,T) ;EP
+1 IF $GET(N)=""
QUIT
+2 SET ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_U_DT_U_T
+3 QUIT
UNREQ ;EP - CALLED FROM SCREENMAN
+1 NEW BCHF
+2 FOR BCHF=3,4,5
DO REQ^DDSUTL(BCHF,2,"ENTER CHR DATA",0)
+3 QUIT
PPINI(REC) ;EP
+1 NEW X,Y,BCHX,BCHY,DIQ,DR,DA,BCHG,BCHINI
+2 SET BCHY=$PIECE(^BCHR(REC,0),U,3)
+3 IF 'BCHY
SET BCHINI="???"
QUIT BCHINI
+4 SET DA=BCHY
SET DIC=200
SET DR=1
SET DIQ="BCHINI"
SET DIQ(0)="I"
+5 DO EN^DIQ1
+6 SET BCHINI=$GET(BCHINI(200,BCHY,1,"I"))
+7 IF BCHINI=""
SET BCHINI="???"
+8 QUIT BCHINI
PPNAME(REC) ;EP
+1 NEW X,Y,BCHX,BCHY,DIQ,DR,DA,BCHG,BCHNAME
+2 SET BCHY=$PIECE(^BCHR(REC,0),U,3)
+3 IF '$DATA(BCHY)
SET BCHNAME="???"
QUIT BCHNAME
+4 SET BCHNAME=$PIECE(^VA(200,BCHY,0),U)
+5 IF BCHNAME=""
SET BCHNAME="???"
+6 QUIT BCHNAME
PPINT(REC) ;
+1 NEW X,Y,BCHX,DIQ,DR,DA,BCHG,BCHY
+2 SET BCHY=$PIECE(^BCHR(REC,0),U,3)
+3 IF '$DATA(BCHY)
SET BCHY="???"
QUIT BCHY
+4 QUIT BCHY
PPAFFL(REC,FORM) ;EP - get pp affiliation internal or external
+1 NEW X,Y,BCHX,BCHY,DIQ,DR,DA,BCHG,BCHAFFL
+2 SET BCHY=$PIECE(^BCHR(REC,0),U,3)
+3 IF 'BCHY
SET BCHAFFL="?"
QUIT BCHAFFL
+4 IF '$DATA(^VA(200,BCHY))
SET BCHAFFL="?"
QUIT BCHAFFL
+5 SET DA=BCHY
SET DIC=200
SET DR=9999999.01
SET DIQ="BCHAFFL"
IF $GET(FORM)="I"
SET DIQ(0)="I"
+6 DO EN^DIQ1
+7 SET BCHAFFL=$SELECT($GET(FORM)="I":BCHAFFL(200,BCHY,9999999.01,"I"),1:BCHAFFL(200,BCHY,"9999999.01"))
+8 IF BCHAFFL=""
SET BCHAFFL="?"
+9 QUIT BCHAFFL
PPCLS(REC,FORM) ;EP
+1 NEW X,Y,BCHX,BCHY,DIQ,DR,DA,BCHG,BCHCLS
+2 SET BCHY=$PIECE(^BCHR(REC,0),U,3)
+3 IF 'BCHY
SET BCHCLS="???"
QUIT BCHCLS
+4 SET DA=BCHY
SET DIC=200
SET DR=53.5
SET DIQ="BCHCLS"
IF $GET(FORM)="I"
SET DIQ(0)="I"
+5 DO EN^DIQ1
+6 SET BCHCLS=$SELECT($GET(FORM)="I":$GET(BCHCLS(200,BCHY,53.5,"I")),1:$GET(BCHCLS(200,BCHY,"53.5")))
+7 IF BCHCLS=""
SET BCHCLS="???"
+8 QUIT BCHCLS
PPCLSC(REC) ;EP GET PRIMARY PROVIDER CLASS CODE
+1 NEW X,Y,CODE,DIC,DR,DA,DIQ,CLS
+2 SET CLS=$$PPCLS^BCHUTIL(REC,"I")
+3 IF CLS="???"
SET CODE="???"
QUIT CODE
+4 SET DIC=7
SET DR="9999999.01"
SET DA=CLS
SET DIQ="CODE"
+5 DO EN^DIQ1
+6 SET CODE=CODE(7,CLS,"9999999.01")
+7 IF CODE=""
SET CODE="???"
+8 QUIT CODE
CALLDIE ;EP
+1 IF '$DATA(DA)
QUIT
+2 IF '$DATA(DIE)
QUIT
+3 IF '$DATA(DR)
QUIT
+4 DO ^DIE
+5 KILL DIE,DIC,DR,DA,D0,D,D1,DO,%X,%Y,X,A,Z,DIU,DIV,DIY,DIW,DIADD,DLAYGO,%,%E,%D,%W,DI,DIFLD,DIG,DIH,DK,DL,DISYS
+6 QUIT
PROVCLC(PROV) ;get provider class code
+1 NEW CODE,A
+2 SET CODE=""
+3 IF 'PROV
QUIT CODE
+4 SET A=$PIECE($GET(^VA(200,PROV,"PS")),U,5)
+5 IF A=""
QUIT CODE
+6 SET CODE=$PIECE($GET(^DIC(7,A,9999999)),U)
+7 QUIT CODE
CANNEDN() ;EP - return canned narrative
+1 NEW BCHX
+2 ;*****CALLED FROM SCREENMAN
+3 SET BCHX=$$GET^DDSVAL(90002.01,.DA,.04,"","I")
IF BCHX
IF $PIECE($GET(^BCHTSERV(BCHX,0)),U,4)
DO HLP^DDSUTL("You must type in a narrative for those services that pass to PCC")
QUIT ""
+4 IF $$GET^DDSVAL(90002.01,.DA,.01,"","I")=""
QUIT "<???>"
+5 IF $$GET^DDSVAL(90002.01,.DA,.04,"","I")=""
QUIT $PIECE(^BCHTPROB($$GET^DDSVAL(90002.01,.DA,.01,"","I"),0),U)
+6 QUIT $EXTRACT($PIECE(^BCHTPROB($$GET^DDSVAL(90002.01,.DA,.01,"","I"),0),U)_":"_$PIECE(^BCHTSERV($$GET^DDSVAL(90002.01,.DA,.04,"","I"),0),U),1,80)
UPDPCC ;EP - called when pcc adds a visit
+1 ;quit if not initiated by chr
IF '$DATA(BCHEV)
QUIT
+2 ;quit if don't know chr record ien
IF '$GET(BCHEV("CHR IEN"))
QUIT
+3 ;quit if no pcc data passed back
IF '$DATA(BCHV)
QUIT
+4 SET DIE="^BCHR("
SET DA=BCHEV("CHR IEN")
SET DR=".15////"_BCHV("VISIT","9000010")
DO CALLDIE
+5 KILL Y,DA,DR,DIE
+6 SET BCHX=0
FOR
SET BCHX=$ORDER(BCHV("VFILES",BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:1
+7 SET BCHY=0
FOR
SET BCHY=$ORDER(BCHV("VFILES",BCHX,BCHY))
IF BCHY'=+BCHY
QUIT
Begin DoDot:2
+8 SET DA=BCHEV("CHR IEN")
SET DR="3101///""`"_BCHX_""""
SET DIE="^BCHR("
+9 SET DR(2,90002.03101)=".02////"_BCHY
+10 DO CALLDIE
+11 KILL DIE,DA,DR,Y,X
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 KILL BCHX,BCHY
+15 QUIT
NARRPOST ;EP
+1 NEW BCHX
+2 IF BCHWTD="Y"
IF X=""
SET BCHWTD="N"
+3 IF BCHWTD="Y"
IF X]""
SET DDSBR=5
QUIT
+4 IF X]""
IF BCHWTD="N"
SET DDACT="CL"
QUIT
+5 SET BCHX=X
+6 IF BCHX=""
SET BCHX=$$CANNEDN^BCHUTIL()
IF BCHX]""
DO PUT^DDSVAL(DIE,.DA,.06,BCHX,"","E")
+7 IF BCHX=""
SET DDSBR=2
+8 ;S DDACT="CL"
+9 QUIT
SC(Y) ;EP - called from input transform
+1 IF $GET(BCHPNP)=""!($GET(BCHPNP)="N")
QUIT 1
+2 IF BCHPNP="P"
IF $PIECE(^BCHTSERV(Y,0),U,6)
QUIT 1
+3 IF BCHPNP="P"
IF '$PIECE(^BCHTSERV(Y,0),U,6)
QUIT 0
+4 QUIT 1
+5 ;
PR(Y) ;EP - called from input transform
+1 ;I $G(BCHPNP)=""!($G(BCHPNP)="N") Q 1
+2 IF $GET(BCHPNP)="P"
IF $PIECE(^BCHTPROB(Y,0),U,2)="AM"
QUIT 0
+3 IF $GET(BCHPNP)="P"
IF $PIECE(^BCHTPROB(Y,0),U,2)="LT"
QUIT 0
+4 QUIT 1
CHKCF ;EP - called from screenman screen
+1 NEW Z
+2 SET Z=$$GET^DDSVAL(DIE,DA,.01,,"I")
+3 SET Z=$PIECE(^BCHTPROB(Z,0),U,2)
+4 IF Z="HB"!(Z="LP")
Begin DoDot:1
+5 IF $PIECE(^BCHTSERV(BCHSERV,0),U,3)="CF"
QUIT
+6 IF $PIECE(^BCHTSERV(BCHSERV,0),U,3)="IT"
QUIT
+7 DO HLP^DDSUTL("For Problem Codes HB and LP you can only use a Service Code of CF or IT.")
SET BCHQ=1
End DoDot:1
+8 QUIT
+9 ;
SETDEFNX(R) ;EP - called from screenman screen
+1 IF '$GET(R)
QUIT ""
+2 NEW X,Y,G,Z
+3 SET G=1
+4 IF $GET(BCHPNP)="P"
QUIT 1
+5 IF $GET(BCHPNP)="N"
QUIT 0
+6 SET X=0
FOR
SET X=$ORDER(^BCHRPROB("AD",R,X))
IF X'=+X
QUIT
Begin DoDot:1
+7 SET Y=$PIECE(^BCHRPROB(X,0),U,1)
+8 IF Y
SET Y=$PIECE(^BCHTPROB(Y,0),U,2)
+9 IF Y="AM"
SET G=0
QUIT
+10 IF Y="LT"
SET G=0
QUIT
+11 IF Y["-"
SET G=0
QUIT
+12 SET Z=$$GET^DDSVAL(90002.01,X,.04,,"I")
+13 IF Z
SET Y=$PIECE(^BCHTSERV(Z,0),U,3)
+14 IF Y="LT"
SET G=0
QUIT
+15 IF Y="AM"
SET G=0
QUIT
+16 IF Y="NF"
SET G=0
QUIT
+17 IF Y="OT"
SET G=0
QUIT
+18 IF Y="CD"
SET G=0
QUIT
+19 QUIT
End DoDot:1
+20 QUIT G
NR ;EP - unrequire .05,spec,city,state
+1 DO REQ^DDSUTL("SPECIALTY",1,1.2,0)
+2 DO REQ^DDSUTL("CITY",1,1.2,0)
+3 DO REQ^DDSUTL("STATE",1,1.2,0)
+4 QUIT
SERCS ;EP - require spec,city,state
+1 IF X=""
Begin DoDot:1
+2 DO REQ^DDSUTL("SPECIALTY",,,1)
+3 DO REQ^DDSUTL("CITY",,,1)
+4 DO REQ^DDSUTL("STATE",,,1)
End DoDot:1
+5 IF X]""
Begin DoDot:1
+6 DO REQ^DDSUTL("SPECIALTY",,,0)
+7 DO REQ^DDSUTL("CITY",,,0)
+8 DO REQ^DDSUTL("STATE",,,0)
End DoDot:1
+9 QUIT
SETDEFTT(R) ;EP - called from screenman screen
+1 IF '$GET(R)
QUIT ""
+2 NEW X,Y,G,Z
+3 SET G=""
+4 IF $GET(BCHPNP)="P"
QUIT ""
+5 SET X=0
FOR
SET X=$ORDER(^BCHRPROB("AD",R,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET Y=$PIECE(^BCHRPROB(X,0),U,1)
+7 IF Y
SET Y=$PIECE(^BCHTPROB(Y,0),U,2)
+8 ;I Y="AM" S G=0 Q
+9 IF Y="LT"
SET G=0
QUIT
+10 ;I Y["-" S G=0 Q
+11 SET Z=$$GET^DDSVAL(90002.01,X,.04,,"I")
+12 IF Z
SET Y=$PIECE(^BCHTSERV(Z,0),U,3)
+13 IF Y="LT"
SET G=0
QUIT
+14 ;I Y="AM" S G=0 Q
+15 ;I Y="NF" S G=0 Q
+16 ;I Y="OT" S G=0 Q
+17 ;I Y="CD" S G=0 Q
+18 QUIT
End DoDot:1
+19 QUIT G
SETDEFAL(R) ;EP - called from screenman screen
+1 IF '$GET(R)
QUIT ""
+2 NEW X,Y,G,Z
+3 SET G=""
+4 SET X=0
FOR
SET X=$ORDER(^BCHRPROB("AD",R,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET Y=$PIECE(^BCHRPROB(X,0),U,1)
+6 IF Y
SET Y=$PIECE(^BCHTPROB(Y,0),U,2)
+7 ;I Y="AM" S G=0 Q
+8 IF Y="LT"
SET G="NONE"
QUIT
+9 ;I Y["-" S G=0 Q
+10 SET Z=$$GET^DDSVAL(90002.01,X,.04,,"I")
+11 IF Z
SET Y=$PIECE(^BCHTSERV(Z,0),U,3)
+12 IF Y="LT"
SET G="NONE"
QUIT
+13 ;I Y="AM" S G=0 Q
+14 ;I Y="NF" S G=0 Q
+15 IF Y="OT"
SET G="NONE"
QUIT
+16 QUIT
End DoDot:1
+17 IF G]""
QUIT $ORDER(^BCHTACTL("B",G,0))
+18 QUIT ""
SETDEFNS ;
+1 NEW %
+2 SET %=$$GET^DDSVAL("^BCHR(",BCHR,.12)
+3 ;I %]"" Q
+4 NEW G
SET G=$$SETDEFNX(BCHR)
+5 IF G]""
DO PUT^DDSVAL("^BCHR(",BCHR,.12,G,,"I")
+6 ;NOW SET DEFAULT ACTIVITY LOCATION
+7 NEW G
SET G=$$SETDEFAL(BCHR)
+8 IF G]""
DO PUT^DDSVAL("^BCHR(",BCHR,.06,G,,"E")
+9 ;NOW SET DEFAULT TRAVEL TIME
+10 SET %=$$GET^DDSVAL("^BCHR(",BCHR,.11)
+11 ;I %]"" Q
+12 NEW G
SET G=$$SETDEFTT(BCHR)
+13 IF G]""
DO PUT^DDSVAL("^BCHR(",BCHR,.11,G,,"I")
+14 QUIT
SETNAR ;EP
+1 IF X=""
QUIT
+2 DO PUT^DDSVAL(DIE,.DA,.06,$PIECE(^BCHTCNAR(X,0),U,1),"","E")
+3 QUIT
SETDICS(PC,SC) ;EP
+1 NEW PCSC,SCE
+2 SET SC=$GET(SC)
+3 IF SC
SET SCE=$PIECE(^BCHTSERV(SC,0),U,3)
+4 SET PC=$GET(PC)
+5 IF PC
SET PC=$PIECE(^BCHTPROB(PC,0),U,2)
+6 SET PCSC=PC_"-"_SCE
+7 IF $DATA(^BCHTCNAR(Y,11,"B",SC))!($DATA(^BCHTSERV(Y,12,"B",PCSC)))
QUIT 1
+8 QUIT 0
GETNARRS(PC,SC) ;
+1 KILL BCHCOUNT,BCHCANNN
+2 KILL ^BCHRPROB(DA,81)
+3 NEW PCSC,SCE,C,X,PCN,V,N,Z,BCHO
+4 SET SCE=""
+5 SET C=0
+6 SET SC=$GET(SC)
+7 IF 'SC
QUIT
+8 IF SC
SET SCE=$PIECE(^BCHTSERV(SC,0),U,3)
+9 SET PC=$GET(PC)
+10 IF 'PC
QUIT
+11 SET PCN=""
+12 IF PC
SET PCN=$PIECE(^BCHTPROB(PC,0),U,1)
SET PC=$PIECE(^BCHTPROB(PC,0),U,2)
+13 SET PCSC=PC_"-"_SCE
+14 ;
+15 SET O=0
FOR
SET O=$ORDER(^BCHTCNAR("ACOMB",PCSC,O))
IF O'=+O
QUIT
Begin DoDot:1
+16 SET X=0
FOR
SET X=$ORDER(^BCHTCNAR("ACOMB",PCSC,O,X))
IF X'=+X
QUIT
Begin DoDot:2
+17 IF $GET(BCHPNP)]""
IF $PIECE(^BCHTCNAR(X,0),U,2)'=BCHPNP
QUIT
+18 IF $GET(BCHPNP)=""
SET V=$PIECE(^BCHPROB(DA,0),U,3)
SET N=$PIECE(^BCHR(V,0),U,12)
IF N'=1
IF $PIECE(^BCHTCNAR(X,0),U,2)'="N"
QUIT
+19 IF $GET(BCHPNP)=""
SET V=$PIECE(^BCHPROB(DA,0),U,3)
SET N=$PIECE(^BCHR(V,0),U,12)
IF N=1
IF $PIECE(^BCHTCNAR(X,0),U,2)'="P"
QUIT
+20 SET Z=$$VAL^XBDIQ1(90002.59,X,.01)
+21 ;$P(Z,"HPC",1)_PCN_$P(Z,"HPC",2)
IF Z["DX-"
SET Z=Z_PC
+22 SET C=C+1
SET BCHCANNN(O)=O_U_Z_""_U_X
End DoDot:2
End DoDot:1
+23 IF $DATA(BCHCANNN)
GOTO SET
+24 ;NOW CHECK SC
+25 SET O=0
FOR
SET O=$ORDER(^BCHTCNAR("ASCO",SCE,O))
IF O'=+O
QUIT
Begin DoDot:1
+26 SET X=0
FOR
SET X=$ORDER(^BCHTCNAR("ASCO",SCE,O,X))
IF X'=+X
QUIT
Begin DoDot:2
+27 IF $GET(BCHPNP)]""
IF $PIECE(^BCHTCNAR(X,0),U,2)'=BCHPNP
QUIT
+28 IF $GET(BCHPNP)=""
SET V=$PIECE(^BCHPROB(DA,0),U,3)
SET N=$PIECE(^BCHR(V,0),U,12)
IF N'=1
IF $PIECE(^BCHTCNAR(X,0),U,2)'="N"
QUIT
+29 IF $GET(BCHPNP)=""
SET V=$PIECE(^BCHPROB(DA,0),U,3)
SET N=$PIECE(^BCHR(V,0),U,12)
IF N=1
IF $PIECE(^BCHTCNAR(X,0),U,2)'="P"
QUIT
+30 SET Z=$$VAL^XBDIQ1(90002.59,X,.01)
+31 IF Z["DX-"
SET Z=Z_PC
+32 SET C=C+1
SET BCHCANNN(O)=O_U_Z_""_U_X
End DoDot:2
End DoDot:1
+33 IF $DATA(BCHCANNN)
DO SET
+34 QUIT
SET ;
+1 NEW X,C,Y
+2 SET Y=0
+3 SET C=0
FOR
SET C=$ORDER(BCHCANNN(C))
IF C'=+C
QUIT
Begin DoDot:1
+4 SET ^BCHRPROB(DA,81,$PIECE(BCHCANNN(C),U,1),0)=$PIECE(BCHCANNN(C),U,1)_U_$PIECE(BCHCANNN(C),U,2)
+5 SET ^BCHRPROB(DA,81,"B",$PIECE(BCHCANNN(C),U,1),$PIECE(BCHCANNN(C),U,1))=""
+6 SET ^BCHRPROB(DA,81,0)="^90002.0181A^"_$PIECE(BCHCANNN(C),U,1)_"^"_C
+7 SET Y=Y+1
+8 SET BCHCOUNT=Y
End DoDot:1
+9 QUIT
N1 ;
+1 IF $GET(BCHCANNN(1))=""
SET Y=""
QUIT
+2 SET Y=$PIECE($GET(BCHCANNN(1)),U,1)_". "_$PIECE($GET(BCHCANNN(1)),U,2)
+3 QUIT
N2 ;
+1 IF $GET(BCHCANNN(2))=""
SET Y=""
QUIT
+2 SET Y=$PIECE($GET(BCHCANNN(2)),U,1)_". "_$PIECE($GET(BCHCANNN(2)),U,2)
+3 QUIT
N3 ;
+1 IF $GET(BCHCANNN(3))=""
SET Y=""
QUIT
+2 SET Y=$PIECE($GET(BCHCANNN(3)),U,1)_". "_$PIECE($GET(BCHCANNN(3)),U,2)
+3 QUIT
N4 ;
+1 IF $GET(BCHCANNN(4))=""
SET Y=""
QUIT
+2 SET Y=$PIECE($GET(BCHCANNN(4)),U,1)_". "_$PIECE($GET(BCHCANNN(4)),U,2)
+3 QUIT
N5 ;
+1 IF $GET(BCHCANNN(5))=""
SET Y=""
QUIT
+2 SET Y=$PIECE($GET(BCHCANNN(5)),U,1)_". "_$PIECE($GET(BCHCANNN(5)),U,2)
+3 QUIT
N6 ;
+1 IF $GET(BCHCANNN(6))=""
SET Y=""
QUIT
+2 SET Y=$PIECE($GET(BCHCANNN(6)),U,1)_". "_$PIECE($GET(BCHCANNN(6)),U,2)
+3 QUIT
SETCNAR ;EP - called from canned narrative block
+1 NEW BCHX,BCHY,BCHZ
+2 SET BCHY=""
+3 SET BCHX=0
FOR
SET BCHX=$ORDER(^BCHRPROB(DA(1),92,BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:1
+4 IF BCHY]""
SET BCHY=BCHY_". "
+5 SET BCHY=BCHY_$PIECE($GET(BCHCANNN($PIECE(^BCHRPROB(DA(1),92,BCHX,0),U,1))),U,2)
End DoDot:1
+6 IF BCHY]""
SET BCHY=BCHY_""
DO PUT^DDSVAL(90002.01,DA(1),.06,$EXTRACT(BCHY,1,158),,"E")
+7 QUIT
NARRPRE ;EP
+1 IF BCHWTD="Y"
IF $$GET^DDSVAL(DIE,DA,.06,,"I")]""
SET DDSBR=5
QUIT
+2 DO HLP^DDSUTL("For services PC, HE, CF, CM, MP, EC and HS you must type a narrative.")
+3 QUIT
ADDNARR ;EP
+1 NEW BCHX,BCHY
+2 IF X=""
QUIT
+3 SET BCHX=$$GET^DDSVAL(DIE,DA,.06,,"E")
+4 SET BCHY=$$GET^DDSVAL(DIE,DA,1101,,"E")
+5 SET BCHX=BCHX_" "_BCHY
+6 DO PUT^DDSVAL(DIE,DA,.06,BCHX,,"E")
+7 DO PUT^DDSVAL(DIE,DA,1101,"",,"I")
+8 QUIT
GETNARRG(PC,SC) ;
+1 KILL BCHCOUNT,BCHCANNN
+2 KILL ^BCHRGAS(DA,81)
+3 NEW PCSC,SCE,C,X,PCN,V,N,Z
+4 SET C=0
+5 SET SC=$GET(SC)
+6 IF 'SC
QUIT
+7 SET SCE=""
+8 IF SC
SET SCE=$PIECE(^BCHTSERV(SC,0),U,3)
+9 SET PC=$GET(PC)
+10 IF 'PC
QUIT
+11 SET PCN=""
+12 IF PC
SET PCN=$PIECE(^BCHTPROB(PC,0),U,1)
SET PC=$PIECE(^BCHTPROB(PC,0),U,2)
+13 SET PCSC=PC_"-"_SCE
+14 ;
+15 SET O=0
FOR
SET O=$ORDER(^BCHTCNAR("ACOMB",PCSC,O))
IF O'=+O
QUIT
Begin DoDot:1
+16 SET X=0
FOR
SET X=$ORDER(^BCHTCNAR("ACOMB",PCSC,O,X))
IF X'=+X
QUIT
Begin DoDot:2
+17 IF $PIECE(^BCHTCNAR(X,0),U,2)'="G"
QUIT
+18 SET Z=$$VAL^XBDIQ1(90002.59,X,.01)
+19 ;_$P(Z,"HPC",2)
IF Z["DX-"
SET Z=Z_PC
+20 SET C=C+1
SET BCHCANNN(O)=O_U_Z_""_U_X
End DoDot:2
End DoDot:1
+21 IF $DATA(BCHCANNN)
GOTO SETG
+22 ;NOW CHECK SC
+23 SET O=0
FOR
SET O=$ORDER(^BCHTCNAR("ASCO",SCE,O))
IF O'=+O
QUIT
Begin DoDot:1
+24 SET X=0
FOR
SET X=$ORDER(^BCHTCNAR("ASCO",SCE,O,X))
IF X'=+X
QUIT
Begin DoDot:2
+25 IF $PIECE(^BCHTCNAR(X,0),U,2)'="G"
QUIT
+26 SET C=C+1
SET BCHCANNN(O)=O_U_$$VAL^XBDIQ1(90002.59,X,.01)_""_U_X
End DoDot:2
End DoDot:1
+27 IF $DATA(BCHCANNN)
DO SETG
+28 QUIT
SETG ;
+1 NEW X,C,Y
+2 SET Y=0
+3 SET C=0
FOR
SET C=$ORDER(BCHCANNN(C))
IF C'=+C
QUIT
Begin DoDot:1
+4 SET ^BCHRGAS(DA,81,C,0)=C_U_$PIECE(BCHCANNN(C),U,2)
+5 SET ^BCHRGAS(DA,81,"B",C,C)=""
+6 SET ^BCHRGAS(DA,81,0)="^90002.9881A^"_C_"^"_C
+7 SET Y=Y+1
+8 SET BCHCOUNT=Y
End DoDot:1
+9 QUIT
+10 ;
NARRPREG ;EP
+1 IF BCHWTD="Y"
IF $$GET^DDSVAL(DIE,DA,.06,,"I")]""
SET DDSBR=5
QUIT
+2 DO HLP^DDSUTL("For services PC, HE, CF, CM, MP, EC and HS you must type a narrative.")
+3 QUIT
+4 ;
NARRPOSG ;EP
+1 NEW BCHX
+2 IF BCHWTD="Y"
IF X=""
SET BCHWTD="N"
+3 IF BCHWTD="Y"
IF X]""
SET DDSBR=5
QUIT
+4 IF X]""
IF BCHWTD="N"
SET DDACT="CL"
QUIT
+5 SET BCHX=X
+6 IF BCHX=""
SET BCHX=$$CANNEDNG^BCHUTIL()
IF BCHX]""
DO PUT^DDSVAL(DIE,.DA,.06,BCHX,"","E")
+7 IF BCHX=""
SET DDSBR=2
+8 ;S DDACT="CL"
+9 QUIT
+10 ;
CANNEDNG() ;EP - return canned narrative
+1 NEW BCHX
+2 ;*****CALLED FROM SCREENMAN
+3 SET BCHX=$$GET^DDSVAL(90002.98,.DA,.04,"","I")
IF BCHX
IF $PIECE($GET(^BCHTSERV(BCHX,0)),U,4)
DO HLP^DDSUTL("You must type in a narrative for those services that pass to PCC")
QUIT ""
+4 IF $$GET^DDSVAL(90002.98,.DA,.01,"","I")=""
QUIT "<???>"
+5 IF $$GET^DDSVAL(90002.98,.DA,.04,"","I")=""
QUIT $PIECE(^BCHTPROB($$GET^DDSVAL(90002.01,.DA,.01,"","I"),0),U)
+6 QUIT $EXTRACT($PIECE(^BCHTPROB($$GET^DDSVAL(90002.98,.DA,.01,"","I"),0),U)_":"_$PIECE(^BCHTSERV($$GET^DDSVAL(90002.98,.DA,.04,"","I"),0),U),1,80)
+7 ;
ADDNARRG ;EP
+1 NEW BCHX,BCHY
+2 IF X=""
QUIT
+3 SET BCHX=$$GET^DDSVAL(DIE,DA,.06,,"E")
+4 SET BCHY=$$GET^DDSVAL(DIE,DA,1101,,"E")
+5 SET BCHX=BCHX_" "_BCHY
+6 DO PUT^DDSVAL(DIE,DA,.06,BCHX,,"E")
+7 DO PUT^DDSVAL(DIE,DA,1101,"",,"I")
+8 QUIT
SETGNAR ;EP - called from canned narrative block
+1 NEW BCHX,BCHY,BCHZ
+2 SET BCHY=""
+3 SET BCHX=0
FOR
SET BCHX=$ORDER(^BCHRGAS(DA(1),92,BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:1
+4 IF BCHY]""
SET BCHY=BCHY_". "
+5 SET BCHY=BCHY_$PIECE($GET(BCHCANNN($PIECE(^BCHRGAS(DA(1),92,BCHX,0),U,1))),U,2)
End DoDot:1
+6 IF BCHY]""
SET BCHY=BCHY_""
DO PUT^DDSVAL(90002.98,DA(1),.06,$EXTRACT(BCHY,1,158),,"E")
+7 QUIT
HELPREF ;EP - called from dd field 8902
+1 NEW BCHX,BCHY,BCHZ
+2 DO EN^DDIOL("Enter a list of Referral Types separated by commas. You can")
+3 DO EN^DDIOL("enter the numbers or the name of the referral type in the list.")
+4 DO EN^DDIOL("Examples: 1,5 or 3 or MEDICAL,NURSING or MD,NR ")
+5 SET BCHX=""
FOR
SET BCHX=$ORDER(^BCHTREF("C",BCHX))
IF BCHX=""
QUIT
Begin DoDot:1
+6 SET BCHY=$ORDER(^BCHTREF("C",BCHX,0))
+7 SET BCHZ=$$VAL^XBDIQ1(90002.52,BCHY,.01)
SET $EXTRACT(BCHZ,25)=$$VAL^XBDIQ1(90002.52,BCHY,.02)
SET $EXTRACT(BCHZ,30)=$$VAL^XBDIQ1(90002.52,BCHY,.03)
+8 DO EN^DDIOL(BCHZ)
+9 QUIT
End DoDot:1
+10 QUIT
REFIT ;EP
+1 NEW A,B,C,D,E,F,S
+2 ;input transform for referral range
+3 IF X?1N
IF $DATA(^BCHTREF("C",X))
QUIT
+4 IF X?1A.E
DO FTR
QUIT
+5 ;GET THE COMMA PIECES
+6 ;STRIP SPACES
+7 SET S=X
+8 SET (S,X)=$$STRIP^XLFSTR(X," ")
+9 FOR A=1:1
SET B=$PIECE(S,",",A)
IF B=""!('$DATA(X))
QUIT
Begin DoDot:1
+10 IF '$DATA(^BCHTREF("C",B))
KILL X
QUIT
End DoDot:1
+11 QUIT
FTR ;
+1 ;PARSE AND CHECK EACH ELEMENT
+2 ;GET THE COMMA PIECES
+3 ;STRIP SPACES
+4 SET S=X
+5 ;$$STRIP^XLFSTR(X,", ")
SET (S,C)=X
+6 FOR A=1:1
SET B=$PIECE(S,",",A)
IF B=""!('$DATA(C))
QUIT
Begin DoDot:1
+7 SET B=$$SB(B)
SET X=B
SET DIC="^BCHTREF("
SET DIC(0)="M"
DO ^DIC
IF Y=-1
KILL C
QUIT
End DoDot:1
+8 IF '$DATA(C)
KILL X
QUIT
+9 SET X=S
+10 QUIT
SB(X) ;EP - Strip leading and trailing blanks from X.
+1 XECUTE ^DD("FUNC",$ORDER(^DD("FUNC","B","STRIPBLANKS",0)),1)
+2 QUIT X
FILEREF ;EP
+1 KILL ^BCHR(BCHR,BCHNODE)
+2 NEW BCHX,BCHY,BCHA,BCHB,BCHC,BCHS,BCHFULL
+3 SET BCHFULL=""
+4 ;input transform for referral range
+5 SET BCHC=0
+6 IF X?1N
IF $DATA(^BCHTREF("C",X))
SET BCHX=$ORDER(^BCHTREF("C",X,0))
DO SETREF
DO REFRESH^DDSUTL
QUIT
+7 IF X?1A.E
DO FTRREF
DO REFRESH^DDSUTL
QUIT
+8 ;GET THE COMMA PIECES
+9 ;STRIP SPACES
+10 SET BCHS=X
+11 SET (BCHS)=$$STRIP^XLFSTR(X," ")
+12 FOR BCHA=1:1
SET BCHB=$PIECE(BCHS,",",BCHA)
IF BCHB=""
QUIT
Begin DoDot:1
+13 SET BCHX=$ORDER(^BCHTREF("C",BCHB,0))
DO SETREF
End DoDot:1
+14 DO REFRESH^DDSUTL
+15 QUIT
FTRREF ;
+1 ;PARSE AND CHECK EACH ELEMENT
+2 ;GET THE COMMA PIECES
+3 ;STRIP SPACES
+4 SET BCHY=X
+5 NEW X,Y
+6 FOR BCHA=1:1
SET BCHB=$PIECE(BCHY,",",BCHA)
IF BCHB=""
QUIT
Begin DoDot:1
+7 SET BCHB=$$SB(BCHB)
SET X=BCHB
SET DIC="^BCHTREF("
SET DIC(0)="M"
DO ^DIC
IF Y=-1
QUIT
+8 SET BCHX=+Y
DO SETREF
End DoDot:1
+9 QUIT
SETREF ;
SET1 ;
+1 SET BCHC=BCHC+1
+2 SET ^BCHR(BCHR,BCHNODE,BCHC,0)=BCHX
+3 SET ^BCHR(BCHR,BCHNODE,"B",BCHX,BCHC)=""
+4 SET ^BCHR(BCHR,BCHNODE,0)="^90002.1"_BCHNODE_"PA^"_BCHC_"^"_BCHC
+5 IF BCHFULL]""
SET BCHFULL=BCHFULL_", "
+6 SET BCHFULL=BCHFULL_$PIECE(^BCHTREF(BCHX,0),U,1)
+7 ;S $P(^BCHR(BCHR,86),U,$S(BCHNODE=41:1,1:2))=BCHFULL
+8 SET F=$SELECT(BCHNODE=41:8601,1:8602)
+9 DO PUT^DDSVAL("^BCHR(",BCHR,F,BCHFULL,,"E")
+10 QUIT
