BSDSCEC ; IHS/ANMC/LJF - PT ASSIGN DETAILS TEMPLATE ;
;;5.3;PIMS;;APR 26, 2002
;
EN ; -- main entry point
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BSDSC PT ASSIGNMENTS")
D CLEAR^VALM1
Q
;
HDR ; -- header code
Q
;
INIT ; -- init variables and list array
K ^TMP("BSDSCEC",$J),^TMP("BSDSCEC1",$J)
D GUIR^XBLM("IHS^SCRPEC","^TMP(""BSDSCEC1"",$J,")
S X=0 F S X=$O(^TMP("BSDSCEC1",$J,X)) Q:'X D
. S VALMCNT=X
. S ^TMP("BSDSCEC",$J,X,0)=^TMP("BSDSCEC1",$J,X)
K ^TMP("BSDSCEC1",$J)
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BSDSCEC",$J)
Q
;
EXPND ; -- expand code
Q
;
FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN) ;EP; format data for report
; called by FORMAT^SCRPEC2
;PTIEN - patient ien
;INS - institution ien
;TIEN - team ien
;PDATA - pt name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov.
;CNAME - clinic name
;CIEN - clinic ien
;
S @STORE@(INS,TIEN,CIEN,PTIEN)=$E($P(PDATA,"^"),1,20) ;patient name
S $E(@STORE@(INS,TIEN,CIEN,PTIEN),22)=$P(PDATA,"^",2) ;primary id
S $E(@STORE@(INS,TIEN,CIEN,PTIEN),32)=$P(PDATA,"^",7) ;last appt
S $E(@STORE@(INS,TIEN,CIEN,PTIEN),57)=$P(PDATA,"^",8) ;next appt
S $E(@STORE@(INS,TIEN,CIEN,PTIEN),77)=$E($P(PDATA,U,9),1,18) ;PC prov.
S $E(@STORE@(INS,TIEN,CIEN,PTIEN),95)=$E($P(PDATA,U,11),1,18) ;PC prov.
S $E(@STORE@(INS,TIEN,CIEN,PTIEN),115)=$E($P(PDATA,U,10),1,18) ;Assoc. Prov.
Q
;
; called by HEADER^SCRPEC2
N HLD
S HLD="H0"
S $E(@STORE@("SUBHEADER",HLD),32)="Last Team"
S $E(@STORE@("SUBHEADER",HLD),57)="Next Team"
S $E(@STORE@("SUBHEADER",HLD),77)="Primary Care"
S $E(@STORE@("SUBHEADER",HLD),95)="Non-PC"
S $E(@STORE@("SUBHEADER",HLD),115)="Associate"
S HLD="H1"
S @STORE@("SUBHEADER",HLD)="Patient Name"
S $E(@STORE@("SUBHEADER",HLD),22)="Pt ID"
S $E(@STORE@("SUBHEADER",HLD),32)="Appt/Clinic"
S $E(@STORE@("SUBHEADER",HLD),57)="Appt/Clinic"
S $E(@STORE@("SUBHEADER",HLD),77)="Provider"
S $E(@STORE@("SUBHEADER",HLD),95)="Provider"
S $E(@STORE@("SUBHEADER",HLD),115)="Provider"
S HLD="H2"
S $P(@STORE@("SUBHEADER",HLD),"=",133)=""
Q
;
GETAPPT(DFN,BSDTM,MODE) ;EP; find next/last appt for any clinic under team
; called by PDATE^SCRPEC
; BSDTM=team ien
; MODE="LAST" or "NEXT"
; BSDX1 will be set as array of providers on team
; BSDX2 will be set as array of clinics for provider
; returns ANS=appt date_" "_clinic abbreviation
;
NEW ANS,CLN,BSDATE,BSDX1,BSDX2
; find all providers on team during last year
S BSDATE("BEGIN")=$$FMADD^XLFDT(DT,-365),BSDATE("END")=DT
S BSDATE("INCL")=0 ;include providers on team anytine in date range
S BSDX1=$$PROV^BSDU3(.BSDTM,.BSDATE,.ARRAY)
;
; for each provider, find all associated clinics
S ANS=$S(MODE="LAST":0,1:9999999)
S BSD=0 F S BSD=$O(@BSDX1@(BSD)) Q:'BSD D
. S PRV=$P(@BSDX1@(BSD),U) Q:'PRV
. K BSDX2 D CLINICS^BSDU3(PRV,.BSDX2)
. ;
. ; for each clinic, find last appt
. S CLN=0 F S CLN=$O(BSDX2(CLN)) Q:'CLN D
.. I MODE="LAST" D
... S APPT=$$GETLAST^SCRPU3(DFN,CLN) ;find last appt for clinic
... I APPT>ANS S ANS=APPT_" "_$$GET1^DIQ(44,CLN,1)
.. I MODE="NEXT" D
... S APPT=$$GETNEXT^SCRPU3(DFN,CLN) ;find next appt for clinic
... I APPT,APPT<ANS S ANS=APPT_" "_$$GET1^DIQ(44,CLN,1)
I ANS=9999999 S ANS=""
Q ANS
BSDSCEC ; IHS/ANMC/LJF - PT ASSIGN DETAILS TEMPLATE ;
+1 ;;5.3;PIMS;;APR 26, 2002
+2 ;
EN ; -- main entry point
+1 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+2 DO EN^VALM("BSDSC PT ASSIGNMENTS")
+3 DO CLEAR^VALM1
+4 QUIT
+5 ;
HDR ; -- header code
+1 QUIT
+2 ;
INIT ; -- init variables and list array
+1 KILL ^TMP("BSDSCEC",$JOB),^TMP("BSDSCEC1",$JOB)
+2 DO GUIR^XBLM("IHS^SCRPEC","^TMP(""BSDSCEC1"",$J,")
+3 SET X=0
FOR
SET X=$ORDER(^TMP("BSDSCEC1",$JOB,X))
IF 'X
QUIT
Begin DoDot:1
+4 SET VALMCNT=X
+5 SET ^TMP("BSDSCEC",$JOB,X,0)=^TMP("BSDSCEC1",$JOB,X)
End DoDot:1
+6 KILL ^TMP("BSDSCEC1",$JOB)
+7 QUIT
+8 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BSDSCEC",$JOB)
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN) ;EP; format data for report
+1 ; called by FORMAT^SCRPEC2
+2 ;PTIEN - patient ien
+3 ;INS - institution ien
+4 ;TIEN - team ien
+5 ;PDATA - pt name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov.
+6 ;CNAME - clinic name
+7 ;CIEN - clinic ien
+8 ;
+9 ;patient name
SET @STORE@(INS,TIEN,CIEN,PTIEN)=$EXTRACT($PIECE(PDATA,"^"),1,20)
+10 ;primary id
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),22)=$PIECE(PDATA,"^",2)
+11 ;last appt
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),32)=$PIECE(PDATA,"^",7)
+12 ;next appt
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),57)=$PIECE(PDATA,"^",8)
+13 ;PC prov.
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),77)=$EXTRACT($PIECE(PDATA,U,9),1,18)
+14 ;PC prov.
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),95)=$EXTRACT($PIECE(PDATA,U,11),1,18)
+15 ;Assoc. Prov.
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),115)=$EXTRACT($PIECE(PDATA,U,10),1,18)
+16 QUIT
+17 ;
+1 ; called by HEADER^SCRPEC2
+2 NEW HLD
+3 SET HLD="H0"
+4 SET $EXTRACT(@STORE@("SUBHEADER",HLD),32)="Last Team"
+5 SET $EXTRACT(@STORE@("SUBHEADER",HLD),57)="Next Team"
+6 SET $EXTRACT(@STORE@("SUBHEADER",HLD),77)="Primary Care"
+7 SET $EXTRACT(@STORE@("SUBHEADER",HLD),95)="Non-PC"
+8 SET $EXTRACT(@STORE@("SUBHEADER",HLD),115)="Associate"
+9 SET HLD="H1"
+10 SET @STORE@("SUBHEADER",HLD)="Patient Name"
+11 SET $EXTRACT(@STORE@("SUBHEADER",HLD),22)="Pt ID"
+12 SET $EXTRACT(@STORE@("SUBHEADER",HLD),32)="Appt/Clinic"
+13 SET $EXTRACT(@STORE@("SUBHEADER",HLD),57)="Appt/Clinic"
+14 SET $EXTRACT(@STORE@("SUBHEADER",HLD),77)="Provider"
+15 SET $EXTRACT(@STORE@("SUBHEADER",HLD),95)="Provider"
+16 SET $EXTRACT(@STORE@("SUBHEADER",HLD),115)="Provider"
+17 SET HLD="H2"
+18 SET $PIECE(@STORE@("SUBHEADER",HLD),"=",133)=""
+19 QUIT
+20 ;
GETAPPT(DFN,BSDTM,MODE) ;EP; find next/last appt for any clinic under team
+1 ; called by PDATE^SCRPEC
+2 ; BSDTM=team ien
+3 ; MODE="LAST" or "NEXT"
+4 ; BSDX1 will be set as array of providers on team
+5 ; BSDX2 will be set as array of clinics for provider
+6 ; returns ANS=appt date_" "_clinic abbreviation
+7 ;
+8 NEW ANS,CLN,BSDATE,BSDX1,BSDX2
+9 ; find all providers on team during last year
+10 SET BSDATE("BEGIN")=$$FMADD^XLFDT(DT,-365)
SET BSDATE("END")=DT
+11 ;include providers on team anytine in date range
SET BSDATE("INCL")=0
+12 SET BSDX1=$$PROV^BSDU3(.BSDTM,.BSDATE,.ARRAY)
+13 ;
+14 ; for each provider, find all associated clinics
+15 SET ANS=$SELECT(MODE="LAST":0,1:9999999)
+16 SET BSD=0
FOR
SET BSD=$ORDER(@BSDX1@(BSD))
IF 'BSD
QUIT
Begin DoDot:1
+17 SET PRV=$PIECE(@BSDX1@(BSD),U)
IF 'PRV
QUIT
+18 KILL BSDX2
DO CLINICS^BSDU3(PRV,.BSDX2)
+19 ;
+20 ; for each clinic, find last appt
+21 SET CLN=0
FOR
SET CLN=$ORDER(BSDX2(CLN))
IF 'CLN
QUIT
Begin DoDot:2
+22 IF MODE="LAST"
Begin DoDot:3
+23 ;find last appt for clinic
SET APPT=$$GETLAST^SCRPU3(DFN,CLN)
+24 IF APPT>ANS
SET ANS=APPT_" "_$$GET1^DIQ(44,CLN,1)
End DoDot:3
+25 IF MODE="NEXT"
Begin DoDot:3
+26 ;find next appt for clinic
SET APPT=$$GETNEXT^SCRPU3(DFN,CLN)
+27 IF APPT
IF APPT<ANS
SET ANS=APPT_" "_$$GET1^DIQ(44,CLN,1)
End DoDot:3
End DoDot:2
End DoDot:1
+28 IF ANS=9999999
SET ANS=""
+29 QUIT ANS
