VIABMS4 ;AAC/JMC,AFS/PB - VIA BMS RPCs ;10/31/17 14:34
;;1.0;VISTA INTEGRATION ADAPTER;**15,20**;06-FEB-2014;Build 5
;Per VA Directive 6402, this routine should not be modified.
;Reference to ^OR(100 supported by IA 6475
;
; OLD 'AF' CODE modified. Evalute DTO between queue start/end times. Also, use only CURRENT ACTION item.
;
LSTORD ; Returns a list of orders from the ORDER file #100;ICR-6475
;Input - VIA("PATH")="LISTORDERS" [required]
; VIA("ORDIEN")=list of orderable IEN separated by a comma (",") [required]. For example, VIA("ORDIEN")="73,75,76,360,740"
; VIA("SDATE")=Start Date for search [optional]. Defaults to today's date, if no date is passed in
; VIA("EDATE")=End Date for search [optional]. Defaults to today's date, if no date is passed in
; VIA("PATIEN")=Patient IEN; multiple IENS separated by a comma [optional]
; VIA("VALUE")=1 or 2 required]. 1 to filter by orderable item(s), 2 to filter by orderable action
; VIA("FROM")=string/value to start list [optional]
; VIA("MAX")=n [optional]
;Data returned
; .01 Order #, 5 Status, .02 Object of Order, 6 Patient Location
N VIAOI,VIACNT,OITM,I,X,Y,Z,CNT,QFLG,MORE,TARRAY
I 'VIAVAL S VIAER="Missing VALUE of 1 or 2" D ERR^VIABMS(VIAER) Q
S:VIASDT="" VIASDT=DT S:VIAEDT="" VIAEDT=DT
D DTCHK^VIABMS(.RESULT,.VIASDT,.VIAEDT) I $D(RESULT) Q
I $G(VIAOIEN)'="" F I=1:1:$L(VIAOIEN,",") S OITM=$P(VIAOIEN,",",I) I OITM'="" S VIAOI(OITM)=""
I $G(VIAPIEN)'="" F I=1:1:$L(VIAPIEN,",") S OITM=$P(VIAPIEN,",",I) I OITM'="" S VIAPIEN(OITM)=""
I VIAVAL=1,$O(VIAOI(""))="" S VIAER="Missing Orderable Items IEN" D ERR^VIABMS(VIAER) Q
S RESULT(1)="[Data]",VIACNT=1,QFLG=0,MORE=""
S X=$S($P(VIAFROM,",")'="":$P(VIAFROM,","),1:VIASDT)
F S X=$O(^OR(100,"AF",X)) Q:('X)!(X>VIAEDT) I X>=VIASDT,X<VIAEDT D I VIACNT>VIAMAX Q
. S Y=0
. ;S Y=$S($P(VIAFROM,",",2)'="":$P(VIAFROM,",",2),1:0),$P(VIAFROM,",",2)=""
. F S Y=$O(^OR(100,"AF",X,Y)) Q:'Y D I VIACNT>VIAMAX S MORE="MORE"_U_X,QFLG=1 Q
. . I VIAVAL=1 S Z=$$ORDACT1()
. . I VIAVAL=2 S Z=$$ORDACT2()
I QFLG D ; re-structure results array when 'more' defined
. M TARRAY=RESULT
. K RESULT
. S CNT=3,I=0,RESULT(1)="[Misc]",RESULT(2)=MORE,RESULT(3)="[Data]"
. F S I=$O(TARRAY(I)) Q:'I D
. . I TARRAY(I)["Data" Q
. . S CNT=CNT+1,RESULT(CNT)=TARRAY(I)
Q
;
ORDACT ; Returns a list of order actions from the ORDER file #100.008
;Input - VIA("PATH")="LISTORDERACTIONS" [required]
; VIA("ORDIEN")=list of orderable IEN separated by a comma (",") [required],if VIA("VALUE")=1
; VIA("SDATE")=Start Date for search [optional]. Defaults to today's date, if no date is passed in
; VIA("EDATE")=End Date for search [optional]. Defaults to today's date, if no date is passed in
; VIA("IENS")=Order IEN [required]
; VIA("VALUE")=1 or 2 required]. 1 to filter by orderable item(s), 2 to filter by orderable action
;Data returned
; .01 Date/Time Ordered,6 Date/Time Signed,16 Release Date/Time,5 Signed By,3 Provider,.1 Order Text
N VIAFILE,VIAFIELDS,VIAFLAGS,OITM,I,TRESULT,I,X,N,IEN,VIATIEN,DATAFLG,VIACA,VIADTO
S VIAFILE=100.008,VIAFIELDS="@;.01;6;16;5;3",VIAFLAGS="IP"
I 'VIAVAL S VIAER="Missing VALUE of 1 or 2" D ERR^VIABMS(VIAER) Q
S:VIASDT="" VIASDT=DT S:VIAEDT="" VIAEDT=DT
D DTCHK^VIABMS(.RESULT,.VIASDT,.VIAEDT) I $D(RESULT) Q
I VIAIENS="" S VIAER="Missing Order number" D ERR^VIABMS(VIAER) Q
I $G(VIAOIEN)'="" F I=1:1:$L(VIAOIEN,",") S OITM=$P(VIAOIEN,",",I) I OITM'="" S VIAOI(OITM)=""
I VIAVAL=1,$O(VIAOI(""))="" S VIAER="Missing Orderable Items IEN" D ERR^VIABMS(VIAER) Q
S VIAID="I $D(^OR(100,DA(1),8,Y,.1)) S I=0 F S I=$O(^OR(100,DA(1),8,Y,.1,I)) Q:'I S J=$P(^(I,0),U) D EN^DDIOL(J)"
I VIAVAL=1 D
. S VIASCRN="S VIACA=$P($G(^OR(100,Y(1),3)),U,7),VIADTO=$P($G(^OR(100,Y(1),3)),U) S:VIACA>0 VIADTO=$P($G(^OR(100,Y(1),8,VIACA,0)),U) "
. S VIASCRN=VIASCRN_"S VIAX=0 F S VIAX=$O(^OR(100,Y(1),.1,VIAX)) Q:'VIAX I VIAX>0 S VIAV=$P(^OR(100,Y(1),.1,VIAX,0),U,1) I (VIACA=+Y1)&$$BETWEEN^VIABMS(VIADTO,VIASDT,VIAEDT)&$D(VIAOI(VIAV)) S VIAOK=1 Q"
I VIAVAL=2 D
. S VIASCRN="S VIACA=$P($G(^OR(100,Y(1),3)),U,7),VIADTO=$P($G(^OR(100,Y(1),3)),U) S:VIACA>0 VIADTO=$P($G(^OR(100,Y(1),8,VIACA,0)),U) "
. S VIASCRN=VIASCRN_"S (VIAB,VIAC,VIAD,VIAX,VIAE)=0,VIAE=((VIACA=+Y1)&$$BETWEEN^VIABMS(VIADTO,VIASDT,VIAEDT)) I VIAE S VIAX=0 F S VIAX=$O(^OR(100,Y(1),8,VIACA,.1,VIAX)) Q:'VIAX S VIAR=$$UP^XLFSTR(^OR(100,Y(1),8,VIACA,.1,VIAX,0)) "
. S VIASCRN=VIASCRN_"S VIAB=VIAB!(VIAR[""ANTICIPATE""),VIAC=VIAC!(VIAR[""PLANNED""),VIAD=VIAD!(VIAR[""DISCHARGE"") I VIAB!VIAC&VIAD Q"
; multiple IENs
S VIATIEN=VIAIENS,N=0,DATAFLG=0
F I=1:1:$L(VIATIEN,",") S IEN=$P(VIATIEN,",",I) I IEN'="" D
. S VIAIENS=","_IEN_","
. K RESULT
. D LDIC^VIABMS
. S X=0 F S X=$O(RESULT(X)) Q:'X D
. . Q:(RESULT(X)["[Data]")&(DATAFLG) I RESULT(X)["[Data]" S DATAFLG=1 ;list [Data] only once
. . S:($L(RESULT(X),U)>6)&($P(RESULT(X),"^")) $P(RESULT(X),"^")=IEN ;avoid length<6, i.e. [Data],[Misc],[Errors] headers/error/misc results. Replaces (RESULT(X)'["[")
. . S N=N+1,TRESULT(N)=RESULT(X)
. K RESULT
I N=0 S TRESULT(1)="[Data]"
M RESULT=TRESULT
Q
;
ORDACT1() ; filters by status, date and orderable items
;Returns =OrderNumber_U_DTO_U_DLA_U_Status_U_ObjectOfOrder_U_PatLocation_U_OrderableItem
N FND,VIA3,VIAV,VIAA,VIA8,VIA0,VIAPT,VIAX
S FND=0
I '$D(^OR(100,Y,.1,0)) Q FND
S VIA0=$G(^OR(100,Y,0)),VIA3=$G(^OR(100,Y,3)),VIAPT=$P(VIA0,U,2)
I $P(VIA3,U,3)'=6 Q FND
I VIAPIEN'="",(VIAPT'["DPT")!('$D(VIAPIEN(+VIAPT))) Q FND
S VIAA=$P(VIA3,U,7),VIAV=$P(VIA3,U)
I VIAA>0 S VIA8=$P(^OR(100,Y,8,VIAA,0),U) I VIA8>=VIASDT,VIA8<VIAEDT S VIAX=0 D Q FND
. F S VIAX=$O(^OR(100,Y,.1,VIAX)) Q:'VIAX I VIAX>0 S VIAV=$P(^OR(100,Y,.1,VIAX,0),U,1) I $D(VIAOI(VIAV)) D Q
. . S FND=1,VIACNT=VIACNT+1,RESULT(VIACNT)=Y_U_VIA8_U_$P(VIA3,U)_U_$P(VIA3,U,3)_U_$P(VIA0,U,2)_U_$P(VIA0,U,10)_U_VIAV
;removed DATE OF LAST ACTIVITY from above criteria
;I VIAA>0,VIAV>=VIASDT,VIAV<VIAEDT S VIA8=$P(^OR(100,Y,8,VIAA,0),U) I VIA8>=VIASDT,VIA8<VIAEDT S VIAX=0 D Q FND
;. F S VIAX=$O(^OR(100,Y,.1,VIAX)) Q:'VIAX I VIAX>0 S VIAV=$P(^OR(100,Y,.1,VIAX,0),U,1) I $D(VIAOI(VIAV)) D Q
;. . S FND=1,VIACNT=VIACNT+1,RESULT(VIACNT)=Y_U_VIA8_U_$P(VIA3,U,3)_U_$P(VIA0,U,2)_U_$P(VIA0,U,10)_U_VIAV
Q FND
;
ORDACT2() ; filters by status, date and orderable actions
N FND,VIA0,VIAA,VIAB,VIAC,VIAD,VIAE,VIAF,VIA3,VIAV,VIA8,VIAX
S FND=0
S VIA0=$G(^OR(100,Y,0))
I $P($G(^OR(100,Y,3)),U,3)'=6 Q FND
S (VIAA,VIAB,VIAC,VIAD)=0
S VIA3=$G(^OR(100,Y,3)),VIAA=$P(VIA3,U,7)
I VIAA>0 S VIA8=$P(^OR(100,Y,8,VIAA,0),U,1) I VIA8>=VIASDT,VIA8<VIAEDT,$D(^OR(100,Y,8,VIAA,.1)) S VIAX=0 D
. F S VIAX=$O(^OR(100,Y,8,VIAA,.1,VIAX)) Q:'VIAX S VIAR=$G(^OR(100,Y,8,VIAA,.1,VIAX,0)),VIAR=$$UP^XLFSTR(VIAR) S VIAB=VIAB!(VIAR["ANTICIPATE"),VIAC=VIAC!(VIAR["PLANNED"),VIAD=VIAD!(VIAR["DISCHARGE") I (VIAB!VIAC)&VIAD D Q
. . S FND=1,VIACNT=VIACNT+1
. . S RESULT(VIACNT)=Y_U_VIA8_U_$P(VIA3,U)_U_$P(VIA3,U,3)_U_$P(VIA0,U,2)_U_$P(VIA0,U,10)_U
Q FND
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVIABMS4 7116 printed Apr 09, 2024@21:47:31 Page 2
VIABMS4 ;AAC/JMC,AFS/PB - VIA BMS RPCs ;10/31/17 14:34
+1 ;;1.0;VISTA INTEGRATION ADAPTER;**15,20**;06-FEB-2014;Build 5
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;Reference to ^OR(100 supported by IA 6475
+4 ;
+5 ; OLD 'AF' CODE modified. Evalute DTO between queue start/end times. Also, use only CURRENT ACTION item.
+6 ;
LSTORD ; Returns a list of orders from the ORDER file #100;ICR-6475
+1 ;Input - VIA("PATH")="LISTORDERS" [required]
+2 ; VIA("ORDIEN")=list of orderable IEN separated by a comma (",") [required]. For example, VIA("ORDIEN")="73,75,76,360,740"
+3 ; VIA("SDATE")=Start Date for search [optional]. Defaults to today's date, if no date is passed in
+4 ; VIA("EDATE")=End Date for search [optional]. Defaults to today's date, if no date is passed in
+5 ; VIA("PATIEN")=Patient IEN; multiple IENS separated by a comma [optional]
+6 ; VIA("VALUE")=1 or 2 required]. 1 to filter by orderable item(s), 2 to filter by orderable action
+7 ; VIA("FROM")=string/value to start list [optional]
+8 ; VIA("MAX")=n [optional]
+9 ;Data returned
+10 ; .01 Order #, 5 Status, .02 Object of Order, 6 Patient Location
+11 NEW VIAOI,VIACNT,OITM,I,X,Y,Z,CNT,QFLG,MORE,TARRAY
+12 IF 'VIAVAL
SET VIAER="Missing VALUE of 1 or 2"
DO ERR^VIABMS(VIAER)
QUIT
+13 if VIASDT=""
SET VIASDT=DT
if VIAEDT=""
SET VIAEDT=DT
+14 DO DTCHK^VIABMS(.RESULT,.VIASDT,.VIAEDT)
IF $DATA(RESULT)
QUIT
+15 IF $GET(VIAOIEN)'=""
FOR I=1:1:$LENGTH(VIAOIEN,",")
SET OITM=$PIECE(VIAOIEN,",",I)
IF OITM'=""
SET VIAOI(OITM)=""
+16 IF $GET(VIAPIEN)'=""
FOR I=1:1:$LENGTH(VIAPIEN,",")
SET OITM=$PIECE(VIAPIEN,",",I)
IF OITM'=""
SET VIAPIEN(OITM)=""
+17 IF VIAVAL=1
IF $ORDER(VIAOI(""))=""
SET VIAER="Missing Orderable Items IEN"
DO ERR^VIABMS(VIAER)
QUIT
+18 SET RESULT(1)="[Data]"
SET VIACNT=1
SET QFLG=0
SET MORE=""
+19 SET X=$SELECT($PIECE(VIAFROM,",")'="":$PIECE(VIAFROM,","),1:VIASDT)
+20 FOR
SET X=$ORDER(^OR(100,"AF",X))
if ('X)!(X>VIAEDT)
QUIT
IF X>=VIASDT
IF X<VIAEDT
Begin DoDot:1
+21 SET Y=0
+22 ;S Y=$S($P(VIAFROM,",",2)'="":$P(VIAFROM,",",2),1:0),$P(VIAFROM,",",2)=""
+23 FOR
SET Y=$ORDER(^OR(100,"AF",X,Y))
if 'Y
QUIT
Begin DoDot:2
+24 IF VIAVAL=1
SET Z=$$ORDACT1()
+25 IF VIAVAL=2
SET Z=$$ORDACT2()
End DoDot:2
IF VIACNT>VIAMAX
SET MORE="MORE"_U_X
SET QFLG=1
QUIT
End DoDot:1
IF VIACNT>VIAMAX
QUIT
+26 ; re-structure results array when 'more' defined
IF QFLG
Begin DoDot:1
+27 MERGE TARRAY=RESULT
+28 KILL RESULT
+29 SET CNT=3
SET I=0
SET RESULT(1)="[Misc]"
SET RESULT(2)=MORE
SET RESULT(3)="[Data]"
+30 FOR
SET I=$ORDER(TARRAY(I))
if 'I
QUIT
Begin DoDot:2
+31 IF TARRAY(I)["Data"
QUIT
+32 SET CNT=CNT+1
SET RESULT(CNT)=TARRAY(I)
End DoDot:2
End DoDot:1
+33 QUIT
+34 ;
ORDACT ; Returns a list of order actions from the ORDER file #100.008
+1 ;Input - VIA("PATH")="LISTORDERACTIONS" [required]
+2 ; VIA("ORDIEN")=list of orderable IEN separated by a comma (",") [required],if VIA("VALUE")=1
+3 ; VIA("SDATE")=Start Date for search [optional]. Defaults to today's date, if no date is passed in
+4 ; VIA("EDATE")=End Date for search [optional]. Defaults to today's date, if no date is passed in
+5 ; VIA("IENS")=Order IEN [required]
+6 ; VIA("VALUE")=1 or 2 required]. 1 to filter by orderable item(s), 2 to filter by orderable action
+7 ;Data returned
+8 ; .01 Date/Time Ordered,6 Date/Time Signed,16 Release Date/Time,5 Signed By,3 Provider,.1 Order Text
+9 NEW VIAFILE,VIAFIELDS,VIAFLAGS,OITM,I,TRESULT,I,X,N,IEN,VIATIEN,DATAFLG,VIACA,VIADTO
+10 SET VIAFILE=100.008
SET VIAFIELDS="@;.01;6;16;5;3"
SET VIAFLAGS="IP"
+11 IF 'VIAVAL
SET VIAER="Missing VALUE of 1 or 2"
DO ERR^VIABMS(VIAER)
QUIT
+12 if VIASDT=""
SET VIASDT=DT
if VIAEDT=""
SET VIAEDT=DT
+13 DO DTCHK^VIABMS(.RESULT,.VIASDT,.VIAEDT)
IF $DATA(RESULT)
QUIT
+14 IF VIAIENS=""
SET VIAER="Missing Order number"
DO ERR^VIABMS(VIAER)
QUIT
+15 IF $GET(VIAOIEN)'=""
FOR I=1:1:$LENGTH(VIAOIEN,",")
SET OITM=$PIECE(VIAOIEN,",",I)
IF OITM'=""
SET VIAOI(OITM)=""
+16 IF VIAVAL=1
IF $ORDER(VIAOI(""))=""
SET VIAER="Missing Orderable Items IEN"
DO ERR^VIABMS(VIAER)
QUIT
+17 SET VIAID="I $D(^OR(100,DA(1),8,Y,.1)) S I=0 F S I=$O(^OR(100,DA(1),8,Y,.1,I)) Q:'I S J=$P(^(I,0),U) D EN^DDIOL(J)"
+18 IF VIAVAL=1
Begin DoDot:1
+19 SET VIASCRN="S VIACA=$P($G(^OR(100,Y(1),3)),U,7),VIADTO=$P($G(^OR(100,Y(1),3)),U) S:VIACA>0 VIADTO=$P($G(^OR(100,Y(1),8,VIACA,0)),U) "
+20 SET VIASCRN=VIASCRN_"S VIAX=0 F S VIAX=$O(^OR(100,Y(1),.1,VIAX)) Q:'VIAX I VIAX>0 S VIAV=$P(^OR(100,Y(1),.1,VIAX,0),U,1) I (VIACA=+Y1)&$$BETWEEN^VIABMS(VIADTO,VIASDT,VIAEDT)&$D(VIAOI(VIAV)) S VIAOK=1 Q"
End DoDot:1
+21 IF VIAVAL=2
Begin DoDot:1
+22 SET VIASCRN="S VIACA=$P($G(^OR(100,Y(1),3)),U,7),VIADTO=$P($G(^OR(100,Y(1),3)),U) S:VIACA>0 VIADTO=$P($G(^OR(100,Y(1),8,VIACA,0)),U) "
+23 SET VIASCRN=VIASCRN_"S (VIAB,VIAC,VIAD,VIAX,VIAE)=0,VIAE=((VIACA=+Y1)&$$BETWEEN^VIABMS(VIADTO,VIASDT,VIAEDT)) I VIAE S VIAX=0 F S VIAX=$O(^OR(100,Y(1),8,VIACA,.1,VIAX)) Q:'VIAX S VIAR=$$UP^XLFSTR(^OR(100,Y(1),8,VIACA,.1,VIAX,0)) "
+24 SET VIASCRN=VIASCRN_"S VIAB=VIAB!(VIAR[""ANTICIPATE""),VIAC=VIAC!(VIAR[""PLANNED""),VIAD=VIAD!(VIAR[""DISCHARGE"") I VIAB!VIAC&VIAD Q"
End DoDot:1
+25 ; multiple IENs
+26 SET VIATIEN=VIAIENS
SET N=0
SET DATAFLG=0
+27 FOR I=1:1:$LENGTH(VIATIEN,",")
SET IEN=$PIECE(VIATIEN,",",I)
IF IEN'=""
Begin DoDot:1
+28 SET VIAIENS=","_IEN_","
+29 KILL RESULT
+30 DO LDIC^VIABMS
+31 SET X=0
FOR
SET X=$ORDER(RESULT(X))
if 'X
QUIT
Begin DoDot:2
+32 ;list [Data] only once
if (RESULT(X)["[Data]")&(DATAFLG)
QUIT
IF RESULT(X)["[Data]"
SET DATAFLG=1
+33 ;avoid length<6, i.e. [Data],[Misc],[Errors] headers/error/misc results. Replaces (RESULT(X)'["[")
if ($LENGTH(RESULT(X),U)>6)&($PIECE(RESULT(X),"^"))
SET $PIECE(RESULT(X),"^")=IEN
+34 SET N=N+1
SET TRESULT(N)=RESULT(X)
End DoDot:2
+35 KILL RESULT
End DoDot:1
+36 IF N=0
SET TRESULT(1)="[Data]"
+37 MERGE RESULT=TRESULT
+38 QUIT
+39 ;
ORDACT1() ; filters by status, date and orderable items
+1 ;Returns =OrderNumber_U_DTO_U_DLA_U_Status_U_ObjectOfOrder_U_PatLocation_U_OrderableItem
+2 NEW FND,VIA3,VIAV,VIAA,VIA8,VIA0,VIAPT,VIAX
+3 SET FND=0
+4 IF '$DATA(^OR(100,Y,.1,0))
QUIT FND
+5 SET VIA0=$GET(^OR(100,Y,0))
SET VIA3=$GET(^OR(100,Y,3))
SET VIAPT=$PIECE(VIA0,U,2)
+6 IF $PIECE(VIA3,U,3)'=6
QUIT FND
+7 IF VIAPIEN'=""
IF (VIAPT'["DPT")!('$DATA(VIAPIEN(+VIAPT)))
QUIT FND
+8 SET VIAA=$PIECE(VIA3,U,7)
SET VIAV=$PIECE(VIA3,U)
+9 IF VIAA>0
SET VIA8=$PIECE(^OR(100,Y,8,VIAA,0),U)
IF VIA8>=VIASDT
IF VIA8<VIAEDT
SET VIAX=0
Begin DoDot:1
+10 FOR
SET VIAX=$ORDER(^OR(100,Y,.1,VIAX))
if 'VIAX
QUIT
IF VIAX>0
SET VIAV=$PIECE(^OR(100,Y,.1,VIAX,0),U,1)
IF $DATA(VIAOI(VIAV))
Begin DoDot:2
+11 SET FND=1
SET VIACNT=VIACNT+1
SET RESULT(VIACNT)=Y_U_VIA8_U_$PIECE(VIA3,U)_U_$PIECE(VIA3,U,3)_U_$PIECE(VIA0,U,2)_U_$PIECE(VIA0,U,10)_U_VIAV
End DoDot:2
QUIT
End DoDot:1
QUIT FND
+12 ;removed DATE OF LAST ACTIVITY from above criteria
+13 ;I VIAA>0,VIAV>=VIASDT,VIAV<VIAEDT S VIA8=$P(^OR(100,Y,8,VIAA,0),U) I VIA8>=VIASDT,VIA8<VIAEDT S VIAX=0 D Q FND
+14 ;. F S VIAX=$O(^OR(100,Y,.1,VIAX)) Q:'VIAX I VIAX>0 S VIAV=$P(^OR(100,Y,.1,VIAX,0),U,1) I $D(VIAOI(VIAV)) D Q
+15 ;. . S FND=1,VIACNT=VIACNT+1,RESULT(VIACNT)=Y_U_VIA8_U_$P(VIA3,U,3)_U_$P(VIA0,U,2)_U_$P(VIA0,U,10)_U_VIAV
+16 QUIT FND
+17 ;
ORDACT2() ; filters by status, date and orderable actions
+1 NEW FND,VIA0,VIAA,VIAB,VIAC,VIAD,VIAE,VIAF,VIA3,VIAV,VIA8,VIAX
+2 SET FND=0
+3 SET VIA0=$GET(^OR(100,Y,0))
+4 IF $PIECE($GET(^OR(100,Y,3)),U,3)'=6
QUIT FND
+5 SET (VIAA,VIAB,VIAC,VIAD)=0
+6 SET VIA3=$GET(^OR(100,Y,3))
SET VIAA=$PIECE(VIA3,U,7)
+7 IF VIAA>0
SET VIA8=$PIECE(^OR(100,Y,8,VIAA,0),U,1)
IF VIA8>=VIASDT
IF VIA8<VIAEDT
IF $DATA(^OR(100,Y,8,VIAA,.1))
SET VIAX=0
Begin DoDot:1
+8 FOR
SET VIAX=$ORDER(^OR(100,Y,8,VIAA,.1,VIAX))
if 'VIAX
QUIT
SET VIAR=$GET(^OR(100,Y,8,VIAA,.1,VIAX,0))
SET VIAR=$$UP^XLFSTR(VIAR)
SET VIAB=VIAB!(VIAR["ANTICIPATE")
SET VIAC=VIAC!(VIAR["PLANNED")
SET VIAD=VIAD!(VIAR["DISCHARGE")
IF (VIAB!VIAC)&VIAD
Begin DoDot:2
+9 SET FND=1
SET VIACNT=VIACNT+1
+10 SET RESULT(VIACNT)=Y_U_VIA8_U_$PIECE(VIA3,U)_U_$PIECE(VIA3,U,3)_U_$PIECE(VIA0,U,2)_U_$PIECE(VIA0,U,10)_U
End DoDot:2
QUIT
End DoDot:1
+11 QUIT FND
