BCHUTIL4 ; IHS/CMI/LAB - UTILITIES ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;
UNREQ ;EP - CALLED FROM SCREENMAN SCREEN
NEW BCHF
F BCHF=3,4,5 D REQ^DDSUTL(BCHF,2,"ENTER CHR DATA",0)
Q
CANNEDNG() ;EP - return canned narrative
NEW BCHX
;*****CALLED FROM SCREENMAN
S BCHX=$$GET^DDSVAL(90002.68,.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.68,.DA,.01,"","I")="" Q "<???>"
I $$GET^DDSVAL(90002.68,.DA,.04,"","I")="" Q $P(^BCHTPROB($$GET^DDSVAL(90002.01,.DA,.01,"","I"),0),U)
Q $E($P(^BCHTPROB($$GET^DDSVAL(90002.68,.DA,.01,"","I"),0),U)_":"_$P(^BCHTSERV($$GET^DDSVAL(90002.68,.DA,.04,"","I"),0),U),1,80)
;
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
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
GETNARRG(PC,SC) ;
K BCHCOUNT,BCHCANNN
K ^BCHGRPDA(DA,81)
NEW PCSC,SCE,C,X,PCN,V,N,Z
S C=0
S SC=$G(SC)
S SCE=""
I SC S SCE=$P(^BCHTSERV(SC,0),U,3)
S PC=$G(PC)
S PCN=""
I PC S PCN=$P(^BCHTPROB(PC,0),U,1),PC=$P(^BCHTPROB(PC,0),U,2)
S PCSC=PC_"-"_SCE
;CHECK PCSC FIRST IN ACOMB
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
..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 ^BCHGRPDA(DA,81,C,0)=C_U_$P(BCHCANNN(C),U,2)
.S ^BCHGRPDA(DA,81,"B",C,C)=""
.S ^BCHGRPDA(DA,81,0)="^90002.6881A^"_C_"^"_C
.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() D:BCHX]"" PUT^DDSVAL(DIE,.DA,.06,BCHX,"","E")
I BCHX="" S DDSBR=2
;S DDACT="CL"
Q
;
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(^BCHGRPDA(DA(1),92,BCHX)) Q:BCHX'=+BCHX D
.I BCHY]"" S BCHY=BCHY_". "
.S BCHY=BCHY_$P($G(BCHCANNN($P(^BCHGRPDA(DA(1),92,BCHX,0),U,1))),U,2)
I BCHY]"" S BCHY=BCHY_"" D PUT^DDSVAL(90002.68,DA(1),.06,$E(BCHY,1,158),,"E")
Q
BCHUTIL4 ; IHS/CMI/LAB - UTILITIES ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;
UNREQ ;EP - CALLED FROM SCREENMAN SCREEN
+1 NEW BCHF
+2 FOR BCHF=3,4,5
DO REQ^DDSUTL(BCHF,2,"ENTER CHR DATA",0)
+3 QUIT
CANNEDNG() ;EP - return canned narrative
+1 NEW BCHX
+2 ;*****CALLED FROM SCREENMAN
+3 SET BCHX=$$GET^DDSVAL(90002.68,.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.68,.DA,.01,"","I")=""
QUIT "<???>"
+5 IF $$GET^DDSVAL(90002.68,.DA,.04,"","I")=""
QUIT $PIECE(^BCHTPROB($$GET^DDSVAL(90002.01,.DA,.01,"","I"),0),U)
+6 QUIT $EXTRACT($PIECE(^BCHTPROB($$GET^DDSVAL(90002.68,.DA,.01,"","I"),0),U)_":"_$PIECE(^BCHTSERV($$GET^DDSVAL(90002.68,.DA,.04,"","I"),0),U),1,80)
+7 ;
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
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
GETNARRG(PC,SC) ;
+1 KILL BCHCOUNT,BCHCANNN
+2 KILL ^BCHGRPDA(DA,81)
+3 NEW PCSC,SCE,C,X,PCN,V,N,Z
+4 SET C=0
+5 SET SC=$GET(SC)
+6 SET SCE=""
+7 IF SC
SET SCE=$PIECE(^BCHTSERV(SC,0),U,3)
+8 SET PC=$GET(PC)
+9 SET PCN=""
+10 IF PC
SET PCN=$PIECE(^BCHTPROB(PC,0),U,1)
SET PC=$PIECE(^BCHTPROB(PC,0),U,2)
+11 SET PCSC=PC_"-"_SCE
+12 ;CHECK PCSC FIRST IN ACOMB
+13 SET O=0
FOR
SET O=$ORDER(^BCHTCNAR("ACOMB",PCSC,O))
IF O'=+O
QUIT
Begin DoDot:1
+14 SET X=0
FOR
SET X=$ORDER(^BCHTCNAR("ACOMB",PCSC,O,X))
IF X'=+X
QUIT
Begin DoDot:2
+15 IF $PIECE(^BCHTCNAR(X,0),U,2)'="G"
QUIT
+16 SET Z=$$VAL^XBDIQ1(90002.59,X,.01)
+17 IF Z["DX-"
SET Z=Z_PC
+18 SET C=C+1
SET BCHCANNN(O)=O_U_Z_""_U_X
End DoDot:2
End DoDot:1
+19 IF $DATA(BCHCANNN)
GOTO SETG
+20 ;NOW CHECK SC
+21 SET O=0
FOR
SET O=$ORDER(^BCHTCNAR("ASCO",SCE,O))
IF O'=+O
QUIT
Begin DoDot:1
+22 SET X=0
FOR
SET X=$ORDER(^BCHTCNAR("ASCO",SCE,O,X))
IF X'=+X
QUIT
Begin DoDot:2
+23 IF $PIECE(^BCHTCNAR(X,0),U,2)'="G"
QUIT
+24 SET C=C+1
SET BCHCANNN(O)=O_U_$$VAL^XBDIQ1(90002.59,X,.01)_""_U_X
End DoDot:2
End DoDot:1
+25 IF $DATA(BCHCANNN)
DO SETG
+26 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 ^BCHGRPDA(DA,81,C,0)=C_U_$PIECE(BCHCANNN(C),U,2)
+5 SET ^BCHGRPDA(DA,81,"B",C,C)=""
+6 SET ^BCHGRPDA(DA,81,0)="^90002.6881A^"_C_"^"_C
+7 SET BCHCOUNT=Y
End DoDot:1
+8 QUIT
+9 ;
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()
IF BCHX]""
DO PUT^DDSVAL(DIE,.DA,.06,BCHX,"","E")
+7 IF BCHX=""
SET DDSBR=2
+8 ;S DDACT="CL"
+9 QUIT
+10 ;
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(^BCHGRPDA(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(^BCHGRPDA(DA(1),92,BCHX,0),U,1))),U,2)
End DoDot:1
+6 IF BCHY]""
SET BCHY=BCHY_""
DO PUT^DDSVAL(90002.68,DA(1),.06,$EXTRACT(BCHY,1,158),,"E")
+7 QUIT
