BTIUPRVI ; IHS/MSC/JS - Problem/Visit Objects ;24-Apr-2014 15:51;DU
;;1.0;TEXT INTEGRATION UTILITIES;**1012,1013**;MAR 20, 2013;Build 33
;Obects for visit-related problem entries from V Visit instructions
;V treatment/regimen and V referral files
Q
;
VIDT(DFN,TARGET,NUM) ; Visit Instructions by date
;Get last (n) date entries for each date of visit instructions
;Default is 99
N ARRAY,PRIEN,INVDT,IEN,VCNT,CNT,EDATE,SIGN,STAT,NARR,SPRIEN,EIE
K @TARGET
S VCNT=0,CNT=0
I $G(NUM)="" S NUM=99
S PRIEN="" F S PRIEN=$O(^AUPNVVI("AE",DFN,PRIEN)) Q:PRIEN="" D
.S INVDT="" F S INVDT=$O(^AUPNVVI("AE",DFN,PRIEN,INVDT)) Q:INVDT="" D
..S IEN="" F S IEN=$O(^AUPNVVI("AE",DFN,PRIEN,INVDT,IEN)) Q:IEN="" D
...S EIE=$$GET1^DIQ(9000010.58,IEN,.06,"I")
...Q:EIE=1
...S STAT=$P($G(^AUPNPROB(PRIEN,0)),U,12)
...Q:STAT="D"
...S ARRAY($P(INVDT,".",1),PRIEN,IEN)=""
S INVDT="" F S INVDT=$O(ARRAY(INVDT)) Q:INVDT=""!(CNT>NUM) D
.S CNT=CNT+1
.Q:CNT>NUM
.S EDATE=9999999-INVDT-1
.S EDATE=$$FMTE^XLFDT(EDATE,5)
.S VCNT=VCNT+1
.S @TARGET@(VCNT,0)=EDATE
.S SPRIEN=0
.S PRIEN="" F S PRIEN=$O(ARRAY(INVDT,PRIEN)) Q:PRIEN=""!(CNT>NUM) D
..S IEN="" F S IEN=$O(ARRAY(INVDT,PRIEN,IEN)) Q:IEN="" D
...S SIGN=$$GET1^DIQ(9000010.58,IEN,.04,"E")
...S NARR=$$GET1^DIQ(9000011,PRIEN,.05)
...I SPRIEN'=PRIEN D
....S SPRIEN=PRIEN
....D PDATA(IEN)
...D TEXT
I VCNT=0 S @TARGET@(1,0)="No visit instructions"
Q "~@"_$NA(@TARGET)
PDATA(IEN) ;Get problem data
S VCNT=VCNT+1
S @TARGET@(VCNT,0)="Problem: "_NARR
Q
;
TEXT ;do the text
N TXTIEN
S VCNT=VCNT+1
S @TARGET@(VCNT,0)=" INSTRUCTIONS:"
S TXTIEN=0 F S TXTIEN=$O(^AUPNVVI(IEN,11,TXTIEN)) Q:'+TXTIEN D
.S VCNT=VCNT+1
.S @TARGET@(VCNT,0)=" "_$G(^AUPNVVI(IEN,11,TXTIEN,0))
S VCNT=VCNT+1
S @TARGET@(VCNT,0)=" Signed by: "_SIGN
S VCNT=VCNT+1
S @TARGET@(VCNT,0)=""
Q
VIPR(DFN,TARGET,NUM) ;Visit instructions by problem
N ARRAY,PRIEN,INVDT,IEN,VCNT,EDATE,SIGN,STAT,SDATE,EIE,IENCNT
K @TARGET
S VCNT=0,CNT=0
I $G(NUM)="" S NUM=99
S PRIEN="" F S PRIEN=$O(^AUPNVVI("AE",DFN,PRIEN)) Q:PRIEN="" D
.S STAT=$P($G(^AUPNPROB(PRIEN,0)),U,12)
.S CNT=0
.Q:STAT="D"
.S NARR=$$GET1^DIQ(9000011,PRIEN,.05)
.S VCNT=VCNT+1
.S @TARGET@(VCNT,0)=NARR
.S SDATE=0
.S INVDT="" F S INVDT=$O(^AUPNVVI("AE",DFN,PRIEN,INVDT)) Q:INVDT=""!(CNT>NUM) D
..I SDATE'=$P(INVDT,".",1) S SDATE=$P(INVDT,".",1),CNT=CNT+1,IENCNT=0
..Q:CNT>NUM
..S IEN="" F S IEN=$O(^AUPNVVI("AE",DFN,PRIEN,INVDT,IEN)) Q:IEN="" D
...S EIE=$$GET1^DIQ(9000010.58,IEN,.06,"I")
...I EIE=1 Q
...S IENCNT=IENCNT+1
...S EDATE=$$GET1^DIQ(9000010.58,IEN,1201,"E")
...S SIGN=$$GET1^DIQ(9000010.58,IEN,.04,"E")
...S VCNT=VCNT+1
...S @TARGET@(VCNT,0)=" "_EDATE
...D TEXT
..I IENCNT=0 S CNT=CNT-1
I VCNT=0 S @TARGET@(1,0)="No visit instructions"
Q "~@"_$NA(@TARGET)
VTRDT(DFN,TARGET,NUM) ; Visit Treatment/Regimens by date
;Get last (n) date entries for each problem of treatments
;Default is 99
N ARRAY,PRIEN,INVDT,IEN,VCNT,EDATE,SIGN,STAT,SNO,IN,OUT,ARR,X,TXT
K @TARGET
S VCNT=0,CNT=0
I $G(NUM)="" S NUM=99
E S NUM=NUM-1
S SNO="" F S SNO=$O(^AUPNVTXR("AE",DFN,SNO)) Q:SNO="" D
.S INVDT="" F S INVDT=$O(^AUPNVTXR("AE",DFN,SNO,INVDT)) Q:INVDT="" D
..S IEN="" F S IEN=$O(^AUPNVTXR("AE",DFN,SNO,INVDT,IEN)) Q:IEN="" D
...S PRIEN=$P($G(^AUPNVTXR(IEN,0)),U,4)
...S STAT=$P($G(^AUPNPROB(PRIEN,0)),U,12)
...Q:STAT="D"
...S ARRAY(INVDT,PRIEN,IEN)=""
S INVDT="" F S INVDT=$O(ARRAY(INVDT)) Q:INVDT="" D
.S EDATE=9999999-INVDT
.S EDATE=$$FMTE^XLFDT(EDATE,5)
.S VCNT=VCNT+1
.S @TARGET@(VCNT,0)=EDATE
.S PRIEN="" F S PRIEN=$O(ARRAY(INVDT,PRIEN)) Q:PRIEN="" D
..S NARR=$$GET1^DIQ(9000011,PRIEN,.05)
..S VCNT=VCNT+1,CNT=CNT+1
..S @TARGET@(VCNT,0)=" "_NARR
..S IEN="" F S IEN=$O(ARRAY(INVDT,PRIEN,IEN)) Q:IEN="" D
...S SNO=$P($G(^AUPNVTXR(IEN,0)),U,1)
...S IN=SNO_"^^^1",OUT="ARR"
...S X=$$CNCLKP^BSTSAPI(.OUT,.IN)
...I X>0 D
....S TXT=ARR(1,"PRE","TRM")
....S VCNT=VCNT+1
....S @TARGET@(VCNT,0)=" "_TXT
..S VCNT=VCNT+1
..S @TARGET@(VCNT,0)=""
I VCNT=0 S @TARGET@(1,0)="No visit treatments"
Q "~@"_$NA(@TARGET)
VTRPR(DFN,TARGET,NUM) ; Visit Treatment/Regimens by problem
;Default is 99
N ARRAY,PRIEN,INVDT,IEN,VCNT,EDATE,SIGN,STAT,SNO,IN,OUT,ARR,X
K @TARGET
S VCNT=0,CNT=0
I $G(NUM)="" S NUM=99
E S NUM=NUM-1
S SNO="" F S SNO=$O(^AUPNVTXR("AE",DFN,SNO)) Q:SNO="" D
.S INVDT="" F S INVDT=$O(^AUPNVTXR("AE",DFN,SNO,INVDT)) Q:INVDT="" D
..S IEN="" F S IEN=$O(^AUPNVTXR("AE",DFN,SNO,INVDT,IEN)) Q:IEN="" D
...S PRIEN=$P($G(^AUPNVTXR(IEN,0)),U,4)
...Q:PRIEN=""
...S STAT=$P($G(^AUPNPROB(PRIEN,0)),U,12)
...Q:STAT="D"
...S ARRAY(PRIEN,INVDT,IEN)=""
S PRIEN="" F S PRIEN=$O(ARRAY(PRIEN)) Q:PRIEN="" D
.S NARR=$$GET1^DIQ(9000011,PRIEN,.05)
.S VCNT=VCNT+1
.S @TARGET@(VCNT,0)=NARR
.S INVDT="" F S INVDT=$O(ARRAY(PRIEN,INVDT)) Q:INVDT="" D
..S CNT=CNT+1
..S EDATE=9999999-INVDT
..S EDATE=$$FMTE^XLFDT(EDATE,5)
..S VCNT=VCNT+1
..S @TARGET@(VCNT,0)=" Date:"_EDATE
..S IEN="" F S IEN=$O(ARRAY(PRIEN,INVDT,IEN)) Q:IEN="" D
...S SNO=$P($G(^AUPNVTXR(IEN,0)),U,1)
...S IN=SNO_"^^^1",OUT="ARR"
...S X=$$CNCLKP^BSTSAPI(.OUT,.IN)
...I X>0 D
....S TXT=ARR(1,"PRE","TRM")
....S VCNT=VCNT+1
....S @TARGET@(VCNT,0)=" "_TXT
..S VCNT=VCNT+1
..S @TARGET@(VCNT,0)=""
I VCNT=0 S @TARGET@(1,0)="No visit treatments"
Q "~@"_$NA(@TARGET)
REFPR(DFN,TARGET,NUM) ; V referrals by problem
;Default is 99
N ARRAY,PRIEN,INVDT,IEN,VCNT,EDATE,SIGN,STAT,SNO,IN,OUT,ARR,X,PRV
K @TARGET
S VCNT=0,CNT=0
I $G(NUM)="" S NUM=99
E S NUM=NUM-1
S SNO="" F S SNO=$O(^AUPNVREF("AE",DFN,SNO)) Q:SNO="" D
.S INVDT="" F S INVDT=$O(^AUPNVREF("AE",DFN,SNO,INVDT)) Q:INVDT="" D
..S IEN="" F S IEN=$O(^AUPNVREF("AE",DFN,SNO,INVDT,IEN)) Q:IEN="" D
...S PRIEN=$P($G(^AUPNVREF(IEN,0)),U,4)
...Q:PRIEN=""
...S STAT=$P($G(^AUPNPROB(PRIEN,0)),U,12)
...Q:STAT="D"
...S ARRAY(PRIEN,INVDT,IEN)=""
S PRIEN="" F S PRIEN=$O(ARRAY(PRIEN)) Q:PRIEN="" D
.S NARR=$$GET1^DIQ(9000011,PRIEN,.05)
.S VCNT=VCNT+1
.S @TARGET@(VCNT,0)="Problem: "_NARR
.S INVDT="" F S INVDT=$O(ARRAY(PRIEN,INVDT)) Q:INVDT="" D
..S CNT=CNT+1
..S EDATE=9999999-INVDT
..S EDATE=$P($$FMTE^XLFDT(EDATE,5),"@",1)
..S IEN="" F S IEN=$O(ARRAY(PRIEN,INVDT,IEN)) Q:IEN="" D
...S SNO=$P($G(^AUPNVREF(IEN,0)),U,1)
...S X=$$CONC^BSTSAPI(SNO_"^^^1")
...I +X D
....S TXT=$P(X,U,4)
....S VCNT=VCNT+1
....S @TARGET@(VCNT,0)=EDATE_" Referral: "_TXT_"("_SNO_")"
....S PRV=$$GET1^DIQ(9000010.59,IEN,1202)
....I PRV="" S PRV=$$GET1^DIQ(9000010.59,IEN,1204)
....S VCNT=VCNT+1
....S @TARGET@(VCNT,0)="Provider: "_PRV
I VCNT=0 S @TARGET@(1,0)="No problem referrals"
Q "~@"_$NA(@TARGET)
REFDT(DFN,TARGET,NUM) ; V referrals by date
;Get last (n) date entries for each problem of visit referrals
;Default is 99
N ARRAY,PRIEN,INVDT,IEN,VCNT,EDATE,SIGN,STAT,SNO,IN,OUT,ARR,X,TXT
K @TARGET
S VCNT=0,CNT=0,STAT=""
I $G(NUM)="" S NUM=99
E S NUM=NUM-1
S SNO="" F S SNO=$O(^AUPNVREF("AE",DFN,SNO)) Q:SNO="" D
.S INVDT="" F S INVDT=$O(^AUPNVREF("AE",DFN,SNO,INVDT)) Q:INVDT="" D
..S IEN="" F S IEN=$O(^AUPNVREF("AE",DFN,SNO,INVDT,IEN)) Q:IEN="" D
...S PRIEN=$P($G(^AUPNVREF(IEN,0)),U,4)
...;Q:PRIEN=""
...I PRIEN'="" S STAT=$P($G(^AUPNPROB(PRIEN,0)),U,12)
...Q:STAT="D"
...S ARRAY(INVDT,IEN)=""
S INVDT="" F S INVDT=$O(ARRAY(INVDT)) Q:INVDT="" D
.S EDATE=9999999-INVDT
.S EDATE=$P($$FMTE^XLFDT(EDATE,5),".")
.S VCNT=VCNT+1,CNT=CNT+1
.S @TARGET@(VCNT,0)=EDATE
.S IEN="" F S IEN=$O(ARRAY(INVDT,IEN)) Q:IEN="" D
..S PRIEN=$P($G(^AUPNVREF(IEN,0)),U,4)
..I +PRIEN D
...S NARR=$$GET1^DIQ(9000011,PRIEN,.05)
...S VCNT=VCNT+1
...S @TARGET@(VCNT,0)="Problem: "_NARR
..S SNO=$P($G(^AUPNVREF(IEN,0)),U,1)
..S X=$$CONC^BSTSAPI(SNO_"^^^1")
..I +X D
...S TXT=$P(X,U,4)
...S VCNT=VCNT+1
...S @TARGET@(VCNT,0)="Referral: "_TXT_"("_SNO_")"
..S PRV=$$GET1^DIQ(9000010.59,IEN,1202)
..I PRV="" S PRV=$$GET1^DIQ(9000010.59,IEN,1204)
..S VCNT=VCNT+1
..S @TARGET@(VCNT,0)="Provider: "_PRV
..S VCNT=VCNT+1
..S @TARGET@(VCNT,0)=""
I VCNT=0 S @TARGET@(1,0)="No visit referrals"
Q "~@"_$NA(@TARGET)
BTIUPRVI ; IHS/MSC/JS - Problem/Visit Objects ;24-Apr-2014 15:51;DU
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1012,1013**;MAR 20, 2013;Build 33
+2 ;Obects for visit-related problem entries from V Visit instructions
+3 ;V treatment/regimen and V referral files
+4 QUIT
+5 ;
VIDT(DFN,TARGET,NUM) ; Visit Instructions by date
+1 ;Get last (n) date entries for each date of visit instructions
+2 ;Default is 99
+3 NEW ARRAY,PRIEN,INVDT,IEN,VCNT,CNT,EDATE,SIGN,STAT,NARR,SPRIEN,EIE
+4 KILL @TARGET
+5 SET VCNT=0
SET CNT=0
+6 IF $GET(NUM)=""
SET NUM=99
+7 SET PRIEN=""
FOR
SET PRIEN=$ORDER(^AUPNVVI("AE",DFN,PRIEN))
IF PRIEN=""
QUIT
Begin DoDot:1
+8 SET INVDT=""
FOR
SET INVDT=$ORDER(^AUPNVVI("AE",DFN,PRIEN,INVDT))
IF INVDT=""
QUIT
Begin DoDot:2
+9 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNVVI("AE",DFN,PRIEN,INVDT,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+10 SET EIE=$$GET1^DIQ(9000010.58,IEN,.06,"I")
+11 IF EIE=1
QUIT
+12 SET STAT=$PIECE($GET(^AUPNPROB(PRIEN,0)),U,12)
+13 IF STAT="D"
QUIT
+14 SET ARRAY($PIECE(INVDT,".",1),PRIEN,IEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+15 SET INVDT=""
FOR
SET INVDT=$ORDER(ARRAY(INVDT))
IF INVDT=""!(CNT>NUM)
QUIT
Begin DoDot:1
+16 SET CNT=CNT+1
+17 IF CNT>NUM
QUIT
+18 SET EDATE=9999999-INVDT-1
+19 SET EDATE=$$FMTE^XLFDT(EDATE,5)
+20 SET VCNT=VCNT+1
+21 SET @TARGET@(VCNT,0)=EDATE
+22 SET SPRIEN=0
+23 SET PRIEN=""
FOR
SET PRIEN=$ORDER(ARRAY(INVDT,PRIEN))
IF PRIEN=""!(CNT>NUM)
QUIT
Begin DoDot:2
+24 SET IEN=""
FOR
SET IEN=$ORDER(ARRAY(INVDT,PRIEN,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+25 SET SIGN=$$GET1^DIQ(9000010.58,IEN,.04,"E")
+26 SET NARR=$$GET1^DIQ(9000011,PRIEN,.05)
+27 IF SPRIEN'=PRIEN
Begin DoDot:4
+28 SET SPRIEN=PRIEN
+29 DO PDATA(IEN)
End DoDot:4
+30 DO TEXT
End DoDot:3
End DoDot:2
End DoDot:1
+31 IF VCNT=0
SET @TARGET@(1,0)="No visit instructions"
+32 QUIT "~@"_$NAME(@TARGET)
PDATA(IEN) ;Get problem data
+1 SET VCNT=VCNT+1
+2 SET @TARGET@(VCNT,0)="Problem: "_NARR
+3 QUIT
+4 ;
TEXT ;do the text
+1 NEW TXTIEN
+2 SET VCNT=VCNT+1
+3 SET @TARGET@(VCNT,0)=" INSTRUCTIONS:"
+4 SET TXTIEN=0
FOR
SET TXTIEN=$ORDER(^AUPNVVI(IEN,11,TXTIEN))
IF '+TXTIEN
QUIT
Begin DoDot:1
+5 SET VCNT=VCNT+1
+6 SET @TARGET@(VCNT,0)=" "_$GET(^AUPNVVI(IEN,11,TXTIEN,0))
End DoDot:1
+7 SET VCNT=VCNT+1
+8 SET @TARGET@(VCNT,0)=" Signed by: "_SIGN
+9 SET VCNT=VCNT+1
+10 SET @TARGET@(VCNT,0)=""
+11 QUIT
VIPR(DFN,TARGET,NUM) ;Visit instructions by problem
+1 NEW ARRAY,PRIEN,INVDT,IEN,VCNT,EDATE,SIGN,STAT,SDATE,EIE,IENCNT
+2 KILL @TARGET
+3 SET VCNT=0
SET CNT=0
+4 IF $GET(NUM)=""
SET NUM=99
+5 SET PRIEN=""
FOR
SET PRIEN=$ORDER(^AUPNVVI("AE",DFN,PRIEN))
IF PRIEN=""
QUIT
Begin DoDot:1
+6 SET STAT=$PIECE($GET(^AUPNPROB(PRIEN,0)),U,12)
+7 SET CNT=0
+8 IF STAT="D"
QUIT
+9 SET NARR=$$GET1^DIQ(9000011,PRIEN,.05)
+10 SET VCNT=VCNT+1
+11 SET @TARGET@(VCNT,0)=NARR
+12 SET SDATE=0
+13 SET INVDT=""
FOR
SET INVDT=$ORDER(^AUPNVVI("AE",DFN,PRIEN,INVDT))
IF INVDT=""!(CNT>NUM)
QUIT
Begin DoDot:2
+14 IF SDATE'=$PIECE(INVDT,".",1)
SET SDATE=$PIECE(INVDT,".",1)
SET CNT=CNT+1
SET IENCNT=0
+15 IF CNT>NUM
QUIT
+16 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNVVI("AE",DFN,PRIEN,INVDT,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+17 SET EIE=$$GET1^DIQ(9000010.58,IEN,.06,"I")
+18 IF EIE=1
QUIT
+19 SET IENCNT=IENCNT+1
+20 SET EDATE=$$GET1^DIQ(9000010.58,IEN,1201,"E")
+21 SET SIGN=$$GET1^DIQ(9000010.58,IEN,.04,"E")
+22 SET VCNT=VCNT+1
+23 SET @TARGET@(VCNT,0)=" "_EDATE
+24 DO TEXT
End DoDot:3
+25 IF IENCNT=0
SET CNT=CNT-1
End DoDot:2
End DoDot:1
+26 IF VCNT=0
SET @TARGET@(1,0)="No visit instructions"
+27 QUIT "~@"_$NAME(@TARGET)
VTRDT(DFN,TARGET,NUM) ; Visit Treatment/Regimens by date
+1 ;Get last (n) date entries for each problem of treatments
+2 ;Default is 99
+3 NEW ARRAY,PRIEN,INVDT,IEN,VCNT,EDATE,SIGN,STAT,SNO,IN,OUT,ARR,X,TXT
+4 KILL @TARGET
+5 SET VCNT=0
SET CNT=0
+6 IF $GET(NUM)=""
SET NUM=99
+7 IF '$TEST
SET NUM=NUM-1
+8 SET SNO=""
FOR
SET SNO=$ORDER(^AUPNVTXR("AE",DFN,SNO))
IF SNO=""
QUIT
Begin DoDot:1
+9 SET INVDT=""
FOR
SET INVDT=$ORDER(^AUPNVTXR("AE",DFN,SNO,INVDT))
IF INVDT=""
QUIT
Begin DoDot:2
+10 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNVTXR("AE",DFN,SNO,INVDT,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+11 SET PRIEN=$PIECE($GET(^AUPNVTXR(IEN,0)),U,4)
+12 SET STAT=$PIECE($GET(^AUPNPROB(PRIEN,0)),U,12)
+13 IF STAT="D"
QUIT
+14 SET ARRAY(INVDT,PRIEN,IEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+15 SET INVDT=""
FOR
SET INVDT=$ORDER(ARRAY(INVDT))
IF INVDT=""
QUIT
Begin DoDot:1
+16 SET EDATE=9999999-INVDT
+17 SET EDATE=$$FMTE^XLFDT(EDATE,5)
+18 SET VCNT=VCNT+1
+19 SET @TARGET@(VCNT,0)=EDATE
+20 SET PRIEN=""
FOR
SET PRIEN=$ORDER(ARRAY(INVDT,PRIEN))
IF PRIEN=""
QUIT
Begin DoDot:2
+21 SET NARR=$$GET1^DIQ(9000011,PRIEN,.05)
+22 SET VCNT=VCNT+1
SET CNT=CNT+1
+23 SET @TARGET@(VCNT,0)=" "_NARR
+24 SET IEN=""
FOR
SET IEN=$ORDER(ARRAY(INVDT,PRIEN,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+25 SET SNO=$PIECE($GET(^AUPNVTXR(IEN,0)),U,1)
+26 SET IN=SNO_"^^^1"
SET OUT="ARR"
+27 SET X=$$CNCLKP^BSTSAPI(.OUT,.IN)
+28 IF X>0
Begin DoDot:4
+29 SET TXT=ARR(1,"PRE","TRM")
+30 SET VCNT=VCNT+1
+31 SET @TARGET@(VCNT,0)=" "_TXT
End DoDot:4
End DoDot:3
+32 SET VCNT=VCNT+1
+33 SET @TARGET@(VCNT,0)=""
End DoDot:2
End DoDot:1
+34 IF VCNT=0
SET @TARGET@(1,0)="No visit treatments"
+35 QUIT "~@"_$NAME(@TARGET)
VTRPR(DFN,TARGET,NUM) ; Visit Treatment/Regimens by problem
+1 ;Default is 99
+2 NEW ARRAY,PRIEN,INVDT,IEN,VCNT,EDATE,SIGN,STAT,SNO,IN,OUT,ARR,X
+3 KILL @TARGET
+4 SET VCNT=0
SET CNT=0
+5 IF $GET(NUM)=""
SET NUM=99
+6 IF '$TEST
SET NUM=NUM-1
+7 SET SNO=""
FOR
SET SNO=$ORDER(^AUPNVTXR("AE",DFN,SNO))
IF SNO=""
QUIT
Begin DoDot:1
+8 SET INVDT=""
FOR
SET INVDT=$ORDER(^AUPNVTXR("AE",DFN,SNO,INVDT))
IF INVDT=""
QUIT
Begin DoDot:2
+9 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNVTXR("AE",DFN,SNO,INVDT,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+10 SET PRIEN=$PIECE($GET(^AUPNVTXR(IEN,0)),U,4)
+11 IF PRIEN=""
QUIT
+12 SET STAT=$PIECE($GET(^AUPNPROB(PRIEN,0)),U,12)
+13 IF STAT="D"
QUIT
+14 SET ARRAY(PRIEN,INVDT,IEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+15 SET PRIEN=""
FOR
SET PRIEN=$ORDER(ARRAY(PRIEN))
IF PRIEN=""
QUIT
Begin DoDot:1
+16 SET NARR=$$GET1^DIQ(9000011,PRIEN,.05)
+17 SET VCNT=VCNT+1
+18 SET @TARGET@(VCNT,0)=NARR
+19 SET INVDT=""
FOR
SET INVDT=$ORDER(ARRAY(PRIEN,INVDT))
IF INVDT=""
QUIT
Begin DoDot:2
+20 SET CNT=CNT+1
+21 SET EDATE=9999999-INVDT
+22 SET EDATE=$$FMTE^XLFDT(EDATE,5)
+23 SET VCNT=VCNT+1
+24 SET @TARGET@(VCNT,0)=" Date:"_EDATE
+25 SET IEN=""
FOR
SET IEN=$ORDER(ARRAY(PRIEN,INVDT,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+26 SET SNO=$PIECE($GET(^AUPNVTXR(IEN,0)),U,1)
+27 SET IN=SNO_"^^^1"
SET OUT="ARR"
+28 SET X=$$CNCLKP^BSTSAPI(.OUT,.IN)
+29 IF X>0
Begin DoDot:4
+30 SET TXT=ARR(1,"PRE","TRM")
+31 SET VCNT=VCNT+1
+32 SET @TARGET@(VCNT,0)=" "_TXT
End DoDot:4
End DoDot:3
+33 SET VCNT=VCNT+1
+34 SET @TARGET@(VCNT,0)=""
End DoDot:2
End DoDot:1
+35 IF VCNT=0
SET @TARGET@(1,0)="No visit treatments"
+36 QUIT "~@"_$NAME(@TARGET)
REFPR(DFN,TARGET,NUM) ; V referrals by problem
+1 ;Default is 99
+2 NEW ARRAY,PRIEN,INVDT,IEN,VCNT,EDATE,SIGN,STAT,SNO,IN,OUT,ARR,X,PRV
+3 KILL @TARGET
+4 SET VCNT=0
SET CNT=0
+5 IF $GET(NUM)=""
SET NUM=99
+6 IF '$TEST
SET NUM=NUM-1
+7 SET SNO=""
FOR
SET SNO=$ORDER(^AUPNVREF("AE",DFN,SNO))
IF SNO=""
QUIT
Begin DoDot:1
+8 SET INVDT=""
FOR
SET INVDT=$ORDER(^AUPNVREF("AE",DFN,SNO,INVDT))
IF INVDT=""
QUIT
Begin DoDot:2
+9 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNVREF("AE",DFN,SNO,INVDT,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+10 SET PRIEN=$PIECE($GET(^AUPNVREF(IEN,0)),U,4)
+11 IF PRIEN=""
QUIT
+12 SET STAT=$PIECE($GET(^AUPNPROB(PRIEN,0)),U,12)
+13 IF STAT="D"
QUIT
+14 SET ARRAY(PRIEN,INVDT,IEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+15 SET PRIEN=""
FOR
SET PRIEN=$ORDER(ARRAY(PRIEN))
IF PRIEN=""
QUIT
Begin DoDot:1
+16 SET NARR=$$GET1^DIQ(9000011,PRIEN,.05)
+17 SET VCNT=VCNT+1
+18 SET @TARGET@(VCNT,0)="Problem: "_NARR
+19 SET INVDT=""
FOR
SET INVDT=$ORDER(ARRAY(PRIEN,INVDT))
IF INVDT=""
QUIT
Begin DoDot:2
+20 SET CNT=CNT+1
+21 SET EDATE=9999999-INVDT
+22 SET EDATE=$PIECE($$FMTE^XLFDT(EDATE,5),"@",1)
+23 SET IEN=""
FOR
SET IEN=$ORDER(ARRAY(PRIEN,INVDT,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+24 SET SNO=$PIECE($GET(^AUPNVREF(IEN,0)),U,1)
+25 SET X=$$CONC^BSTSAPI(SNO_"^^^1")
+26 IF +X
Begin DoDot:4
+27 SET TXT=$PIECE(X,U,4)
+28 SET VCNT=VCNT+1
+29 SET @TARGET@(VCNT,0)=EDATE_" Referral: "_TXT_"("_SNO_")"
+30 SET PRV=$$GET1^DIQ(9000010.59,IEN,1202)
+31 IF PRV=""
SET PRV=$$GET1^DIQ(9000010.59,IEN,1204)
+32 SET VCNT=VCNT+1
+33 SET @TARGET@(VCNT,0)="Provider: "_PRV
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+34 IF VCNT=0
SET @TARGET@(1,0)="No problem referrals"
+35 QUIT "~@"_$NAME(@TARGET)
REFDT(DFN,TARGET,NUM) ; V referrals by date
+1 ;Get last (n) date entries for each problem of visit referrals
+2 ;Default is 99
+3 NEW ARRAY,PRIEN,INVDT,IEN,VCNT,EDATE,SIGN,STAT,SNO,IN,OUT,ARR,X,TXT
+4 KILL @TARGET
+5 SET VCNT=0
SET CNT=0
SET STAT=""
+6 IF $GET(NUM)=""
SET NUM=99
+7 IF '$TEST
SET NUM=NUM-1
+8 SET SNO=""
FOR
SET SNO=$ORDER(^AUPNVREF("AE",DFN,SNO))
IF SNO=""
QUIT
Begin DoDot:1
+9 SET INVDT=""
FOR
SET INVDT=$ORDER(^AUPNVREF("AE",DFN,SNO,INVDT))
IF INVDT=""
QUIT
Begin DoDot:2
+10 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNVREF("AE",DFN,SNO,INVDT,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+11 SET PRIEN=$PIECE($GET(^AUPNVREF(IEN,0)),U,4)
+12 ;Q:PRIEN=""
+13 IF PRIEN'=""
SET STAT=$PIECE($GET(^AUPNPROB(PRIEN,0)),U,12)
+14 IF STAT="D"
QUIT
+15 SET ARRAY(INVDT,IEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+16 SET INVDT=""
FOR
SET INVDT=$ORDER(ARRAY(INVDT))
IF INVDT=""
QUIT
Begin DoDot:1
+17 SET EDATE=9999999-INVDT
+18 SET EDATE=$PIECE($$FMTE^XLFDT(EDATE,5),".")
+19 SET VCNT=VCNT+1
SET CNT=CNT+1
+20 SET @TARGET@(VCNT,0)=EDATE
+21 SET IEN=""
FOR
SET IEN=$ORDER(ARRAY(INVDT,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+22 SET PRIEN=$PIECE($GET(^AUPNVREF(IEN,0)),U,4)
+23 IF +PRIEN
Begin DoDot:3
+24 SET NARR=$$GET1^DIQ(9000011,PRIEN,.05)
+25 SET VCNT=VCNT+1
+26 SET @TARGET@(VCNT,0)="Problem: "_NARR
End DoDot:3
+27 SET SNO=$PIECE($GET(^AUPNVREF(IEN,0)),U,1)
+28 SET X=$$CONC^BSTSAPI(SNO_"^^^1")
+29 IF +X
Begin DoDot:3
+30 SET TXT=$PIECE(X,U,4)
+31 SET VCNT=VCNT+1
+32 SET @TARGET@(VCNT,0)="Referral: "_TXT_"("_SNO_")"
End DoDot:3
+33 SET PRV=$$GET1^DIQ(9000010.59,IEN,1202)
+34 IF PRV=""
SET PRV=$$GET1^DIQ(9000010.59,IEN,1204)
+35 SET VCNT=VCNT+1
+36 SET @TARGET@(VCNT,0)="Provider: "_PRV
+37 SET VCNT=VCNT+1
+38 SET @TARGET@(VCNT,0)=""
End DoDot:2
End DoDot:1
+39 IF VCNT=0
SET @TARGET@(1,0)="No visit referrals"
+40 QUIT "~@"_$NAME(@TARGET)
