PSOPFSU0 ;BIR/LE,AM - PFSS Get Account & Utilities ;08/09/93
;;7.0;OUTPATIENT PHARMACY;**201,225**;DEC 1997;Build 29
;External reference SWSTAT^IBBAPI supported by DBIA 4663
;External reference GETACCT^IBBAPI supported by DBIA 4664
;External reference ^DG(40.8,"AD" supported by DBIA 2817
Q
;
GACT(PSORXN,PSOREF) ;ENTRY POINT: Called from PSON52; PSOR52, PSORN52. Get a PFSS acct ref
; This routine is only called when the PFSS Switch is on.
;
N I,J,PSOPFSAC,PSOPV1,PSODG,PSOZCL,PSODFN,PSORX,PSOPV2,PSODIV
;for sending to an external billing system, get data from file 52, build arrays for IBB API call
I PSOREF=0 D GACTOF
I PSOREF>0 D GACTRF
;Get general Rx data fields
S PSODIV=$$MCDIV(PSORXN,PSOREF)
S PSODFN=$$GET1^DIQ(52,PSORXN,"2","I")
S PSOPV1(2)="O",PSOPV1(50)=PSORXN
S PSOPV1(3)=$$CHLOC()
Q:PSOPV1(3)="" 0 ;can't do GETACCT if CHARGE LOCATION is null; this is to be address in subsequent PFSS project phase
;request the PFSS Acct Rev
S PSOPFSAC=$$GETACCT^IBBAPI(PSODFN,"","A04","GACT;PSOPFSU0",.PSOPV1,"","",.PSODG,.PSOZCL,PSODIV,"")
;Store the PFS Acct Ref with speed in mind
Q:PSOPFSAC<1 ""
I PSOREF=0 S $P(^PSRX(PSORXN,"PFS"),"^")=PSOPFSAC
I PSOREF>0 S $P(^PSRX(PSORXN,1,PSOREF,"PFS"),"^")=PSOPFSAC
Q PSOPFSAC
;
GACTOF ;Get orig fill data
D GETS^DIQ(52,PSORXN,"4;22","I","PSORX")
S PSOPV1(7)=$G(PSORX(52,PSORXN_",",4,"I")),PSOPV1(44)=$G(PSORX(52,PSORXN_",",22,"I"))
D GOC
Q
;
GACTRF ;Called from GACT. Get refill data
D GETS^DIQ(52.1,PSOREF_","_PSORXN,".01;15","I","PSORX")
S PSOPV1(7)=$G(PSORX(52.1,PSOREF_","_PSORXN_",","15","I"))
S PSOPV1(44)=$G(PSORX(52.1,PSOREF_","_PSORXN_",",".01","I"))
D GOC
Q
;
CHLOC() ;FIND CHARGE LOCATION
N CHLOC,CL,PDIV
I PSOREF=0 S PDIV=$$GET1^DIQ(52,PSORXN,"20","I") ;DIVISION
I PSOREF>0 S PDIV=$$GET1^DIQ(52.1,PSOREF_","_PSORXN_",","8","I")
S CHLOC=$$GET1^DIQ(59,PDIV,1007,"I") ;Charge location pointer
I CHLOC="" S CL="" D CLOK S:CL>0 CHLOC=CL
Q CHLOC
;
GOC ;Called from GACTOF and GACTRF. Parse OP classifications and ICD's. Don't send null values.
D GETS^DIQ(52,PSORXN,"52311*","I","PSORX")
F I=1:1 Q:'$D(PSORX(52.052311,I_","_PSORXN_",")) D
. S:PSORX(52.052311,I_","_PSORXN_",",".01","I")'="" PSODG(I,3)=PSORX(52.052311,I_","_PSORXN_",",".01","I"),PSODG(I,6)="W"
. I I=1 F J=1:1:8 Q:'$D(PSORX(52.052311,I_","_PSORXN_",",J,"I")) D
. . S:PSORX(52.052311,I_","_PSORXN_",",J,"I")'="" PSOZCL(J,2)=J,PSOZCL(J,3)=PSORX(52.052311,I_","_PSORXN_",",J,"I")
S:'$D(PSOZCL) PSOZCL="" S:'$D(PSODG) PSODG=""
Q
;
RPH(PSORXN,PSOREF) ;API entry point
; Inputs: PSORXN = prescription IEN, PSOREF = fill number
; Outputs: PSORPH = rel pharm IEN ^ user IEN who performed last activity or rel pharm iF no activity entries^
; IB Service Section pointer from file 59
; Returns null values when the Rx is not released or the input values are invalid (i.e. "^^").
N I,II,IBSS,DIV,PSORPH,PSOEDPH,PSOA,PSORDT,PSOOK,PSOA,DATA
S PSOOK=$$CHKRX(PSORXN,PSOREF) Q:PSOOK'=1 "^^"
I 'PSOREF D GETS^DIQ(52,PSORXN,"20;23;31","I","DATA")
E D GETS^DIQ(52.1,PSOREF_","_PSORXN,"4;8;17","I","DATA")
I PSOREF=0 D
. S PSORPH=+$G(DATA(52,PSORXN_",",23,"I")) S:PSORPH=0 PSORPH=""
. S DIV=+$G(DATA(52,PSORXN_",",20,"I"))
. S PSORDT=+$G(DATA(52,PSORXN_",",31,"I"))
I PSOREF>0 D
. S PSORPH=+$G(DATA(52.1,PSOREF_","_PSORXN_",",4,"I")) S:PSORPH=0 PSORPH=""
. S DIV=+$G(DATA(52.1,PSOREF_","_PSORXN_",",8,"I"))
. S PSORDT=+$G(DATA(52.1,PSOREF_","_PSORXN_",",17,"I"))
Q:PSORDT=0 "^^"
;last activity - get last one with a user
I $D(^PSRX(PSORXN,"A",0)) S PSOA=$P(^PSRX(PSORXN,"A",0),"^",3) D
. F II=PSOA:-1:1 S PSOEDPH=$$GET1^DIQ(52.3,II_","_PSORXN_",",".03","I") Q:PSOEDPH'=""
;get IB Service Section (requested by Ed Z. on 6/29/05)
S IBSS=$P($G(^PS(59,DIV,"IB")),"^")
S:'$G(PSOEDPH) PSOEDPH=PSORPH
S PSORPH=$G(PSORPH)_"^"_$G(PSOEDPH)_"^"_$G(IBSS)
Q PSORPH
;
CHKRX(PSORX,PSOF) ;validates Rx & fill. 0=not valid, 1=valid, 2=refill not valid
Q:PSORX=""!(PSOF="") 0
Q:'$D(^PSRX(PSORX)) 0
Q:PSOF>0&('$D(^PSRX(PSORX,1,PSOF))) 2
Q 1
;
MCDIV(RX,FILL) ;Get MC DIVISION from the Rx/Fill
N DIV,INST
; outpatient division
I 'FILL S DIV=$$GET1^DIQ(52,RX,20,"I")
E S DIV=$$GET1^DIQ(52.1,FILL_","_RX,8,"I")
Q:'DIV ""
; related institution
S INST=$$GET1^DIQ(59,DIV,100,"I") Q:'INST ""
S DIV=$O(^DG(40.8,"AD",INST,0)) ; pointer to medical center division
Q DIV
;
CLOK ;
N I S I=0 F S I=$O(^PS(59,I)) Q:'I!(CL>0) D
. I $S('$D(^PS(59,I,"I")):1,'+$P(^("I"),"^"):1,DT'>+$P(^("I"),"^"):1,1:0) S CL=$P($G(^PS(59,I,"PFS")),"^")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOPFSU0 4657 printed Dec 13, 2024@02:32:40 Page 2
PSOPFSU0 ;BIR/LE,AM - PFSS Get Account & Utilities ;08/09/93
+1 ;;7.0;OUTPATIENT PHARMACY;**201,225**;DEC 1997;Build 29
+2 ;External reference SWSTAT^IBBAPI supported by DBIA 4663
+3 ;External reference GETACCT^IBBAPI supported by DBIA 4664
+4 ;External reference ^DG(40.8,"AD" supported by DBIA 2817
+5 QUIT
+6 ;
GACT(PSORXN,PSOREF) ;ENTRY POINT: Called from PSON52; PSOR52, PSORN52. Get a PFSS acct ref
+1 ; This routine is only called when the PFSS Switch is on.
+2 ;
+3 NEW I,J,PSOPFSAC,PSOPV1,PSODG,PSOZCL,PSODFN,PSORX,PSOPV2,PSODIV
+4 ;for sending to an external billing system, get data from file 52, build arrays for IBB API call
+5 IF PSOREF=0
DO GACTOF
+6 IF PSOREF>0
DO GACTRF
+7 ;Get general Rx data fields
+8 SET PSODIV=$$MCDIV(PSORXN,PSOREF)
+9 SET PSODFN=$$GET1^DIQ(52,PSORXN,"2","I")
+10 SET PSOPV1(2)="O"
SET PSOPV1(50)=PSORXN
+11 SET PSOPV1(3)=$$CHLOC()
+12 ;can't do GETACCT if CHARGE LOCATION is null; this is to be address in subsequent PFSS project phase
if PSOPV1(3)=""
QUIT 0
+13 ;request the PFSS Acct Rev
+14 SET PSOPFSAC=$$GETACCT^IBBAPI(PSODFN,"","A04","GACT;PSOPFSU0",.PSOPV1,"","",.PSODG,.PSOZCL,PSODIV,"")
+15 ;Store the PFS Acct Ref with speed in mind
+16 if PSOPFSAC<1
QUIT ""
+17 IF PSOREF=0
SET $PIECE(^PSRX(PSORXN,"PFS"),"^")=PSOPFSAC
+18 IF PSOREF>0
SET $PIECE(^PSRX(PSORXN,1,PSOREF,"PFS"),"^")=PSOPFSAC
+19 QUIT PSOPFSAC
+20 ;
GACTOF ;Get orig fill data
+1 DO GETS^DIQ(52,PSORXN,"4;22","I","PSORX")
+2 SET PSOPV1(7)=$GET(PSORX(52,PSORXN_",",4,"I"))
SET PSOPV1(44)=$GET(PSORX(52,PSORXN_",",22,"I"))
+3 DO GOC
+4 QUIT
+5 ;
GACTRF ;Called from GACT. Get refill data
+1 DO GETS^DIQ(52.1,PSOREF_","_PSORXN,".01;15","I","PSORX")
+2 SET PSOPV1(7)=$GET(PSORX(52.1,PSOREF_","_PSORXN_",","15","I"))
+3 SET PSOPV1(44)=$GET(PSORX(52.1,PSOREF_","_PSORXN_",",".01","I"))
+4 DO GOC
+5 QUIT
+6 ;
CHLOC() ;FIND CHARGE LOCATION
+1 NEW CHLOC,CL,PDIV
+2 ;DIVISION
IF PSOREF=0
SET PDIV=$$GET1^DIQ(52,PSORXN,"20","I")
+3 IF PSOREF>0
SET PDIV=$$GET1^DIQ(52.1,PSOREF_","_PSORXN_",","8","I")
+4 ;Charge location pointer
SET CHLOC=$$GET1^DIQ(59,PDIV,1007,"I")
+5 IF CHLOC=""
SET CL=""
DO CLOK
if CL>0
SET CHLOC=CL
+6 QUIT CHLOC
+7 ;
GOC ;Called from GACTOF and GACTRF. Parse OP classifications and ICD's. Don't send null values.
+1 DO GETS^DIQ(52,PSORXN,"52311*","I","PSORX")
+2 FOR I=1:1
if '$DATA(PSORX(52.052311,I_","_PSORXN_","))
QUIT
Begin DoDot:1
+3 if PSORX(52.052311,I_","_PSORXN_",",".01","I")'=""
SET PSODG(I,3)=PSORX(52.052311,I_","_PSORXN_",",".01","I")
SET PSODG(I,6)="W"
+4 IF I=1
FOR J=1:1:8
if '$DATA(PSORX(52.052311,I_","_PSORXN_",",J,"I"))
QUIT
Begin DoDot:2
+5 if PSORX(52.052311,I_","_PSORXN_",",J,"I")'=""
SET PSOZCL(J,2)=J
SET PSOZCL(J,3)=PSORX(52.052311,I_","_PSORXN_",",J,"I")
End DoDot:2
End DoDot:1
+6 if '$DATA(PSOZCL)
SET PSOZCL=""
if '$DATA(PSODG)
SET PSODG=""
+7 QUIT
+8 ;
RPH(PSORXN,PSOREF) ;API entry point
+1 ; Inputs: PSORXN = prescription IEN, PSOREF = fill number
+2 ; Outputs: PSORPH = rel pharm IEN ^ user IEN who performed last activity or rel pharm iF no activity entries^
+3 ; IB Service Section pointer from file 59
+4 ; Returns null values when the Rx is not released or the input values are invalid (i.e. "^^").
+5 NEW I,II,IBSS,DIV,PSORPH,PSOEDPH,PSOA,PSORDT,PSOOK,PSOA,DATA
+6 SET PSOOK=$$CHKRX(PSORXN,PSOREF)
if PSOOK'=1
QUIT "^^"
+7 IF 'PSOREF
DO GETS^DIQ(52,PSORXN,"20;23;31","I","DATA")
+8 IF '$TEST
DO GETS^DIQ(52.1,PSOREF_","_PSORXN,"4;8;17","I","DATA")
+9 IF PSOREF=0
Begin DoDot:1
+10 SET PSORPH=+$GET(DATA(52,PSORXN_",",23,"I"))
if PSORPH=0
SET PSORPH=""
+11 SET DIV=+$GET(DATA(52,PSORXN_",",20,"I"))
+12 SET PSORDT=+$GET(DATA(52,PSORXN_",",31,"I"))
End DoDot:1
+13 IF PSOREF>0
Begin DoDot:1
+14 SET PSORPH=+$GET(DATA(52.1,PSOREF_","_PSORXN_",",4,"I"))
if PSORPH=0
SET PSORPH=""
+15 SET DIV=+$GET(DATA(52.1,PSOREF_","_PSORXN_",",8,"I"))
+16 SET PSORDT=+$GET(DATA(52.1,PSOREF_","_PSORXN_",",17,"I"))
End DoDot:1
+17 if PSORDT=0
QUIT "^^"
+18 ;last activity - get last one with a user
+19 IF $DATA(^PSRX(PSORXN,"A",0))
SET PSOA=$PIECE(^PSRX(PSORXN,"A",0),"^",3)
Begin DoDot:1
+20 FOR II=PSOA:-1:1
SET PSOEDPH=$$GET1^DIQ(52.3,II_","_PSORXN_",",".03","I")
if PSOEDPH'=""
QUIT
End DoDot:1
+21 ;get IB Service Section (requested by Ed Z. on 6/29/05)
+22 SET IBSS=$PIECE($GET(^PS(59,DIV,"IB")),"^")
+23 if '$GET(PSOEDPH)
SET PSOEDPH=PSORPH
+24 SET PSORPH=$GET(PSORPH)_"^"_$GET(PSOEDPH)_"^"_$GET(IBSS)
+25 QUIT PSORPH
+26 ;
CHKRX(PSORX,PSOF) ;validates Rx & fill. 0=not valid, 1=valid, 2=refill not valid
+1 if PSORX=""!(PSOF="")
QUIT 0
+2 if '$DATA(^PSRX(PSORX))
QUIT 0
+3 if PSOF>0&('$DATA(^PSRX(PSORX,1,PSOF)))
QUIT 2
+4 QUIT 1
+5 ;
MCDIV(RX,FILL) ;Get MC DIVISION from the Rx/Fill
+1 NEW DIV,INST
+2 ; outpatient division
+3 IF 'FILL
SET DIV=$$GET1^DIQ(52,RX,20,"I")
+4 IF '$TEST
SET DIV=$$GET1^DIQ(52.1,FILL_","_RX,8,"I")
+5 if 'DIV
QUIT ""
+6 ; related institution
+7 SET INST=$$GET1^DIQ(59,DIV,100,"I")
if 'INST
QUIT ""
+8 ; pointer to medical center division
SET DIV=$ORDER(^DG(40.8,"AD",INST,0))
+9 QUIT DIV
+10 ;
CLOK ;
+1 NEW I
SET I=0
FOR
SET I=$ORDER(^PS(59,I))
if 'I!(CL>0)
QUIT
Begin DoDot:1
+2 IF $SELECT('$DATA(^PS(59,I,"I")):1,'+$PIECE(^("I"),"^"):1,DT'>+$PIECE(^("I"),"^"):1,1:0)
SET CL=$PIECE($GET(^PS(59,I,"PFS")),"^")
End DoDot:1
+3 QUIT
+4 ;
