RTSM61 ;PKE/ISC-ALBANY more clinic requests sh. admis. ;9/1/90
;;v 2.0;Record Tracking;;10/22/91
EN F A=0:0 S A=$O(^RTV(195.9,"AD","y",A)) Q:'A I $D(^RTV(195.9,A,"ADM")),$D(^(0)) S RTSA(A)=$P(^(0),"^",1,3)_"^"_$P(^("ADM"),"^",2)
;
I $D(^DIC(195.1,+^DIC(195.4,1,"MAS"),4)) S RTSA("MAS")=$P(^(4),"^",2)_"^^"_+^DIC(195.4,1,"MAS")
I $D(^DIC(195.1,+^DIC(195.4,1,"RAD"),4)) S RTSA("RAD")=$P(^(4),"^",2)_"^^"_+^DIC(195.4,1,"RAD")
K A,B
ST S X="T",%DT="" D ^%DT S RTBEG=Y S X="T+"_(0+$S($D(^DIC(195.4,1,0)):$S($P(^(0),"^",6):$P(^(0),"^",6),1:7),1:7)) D ^%DT S RTEND=Y_".2359" K %DT
;S RTBEG=2880101
;
START F RTTM=(RTBEG-.0001):0 S RTTM=$O(^DGS(41.1,"C",RTTM)) Q:'RTTM!(RTEND<RTTM) F RTSAA=0:0 S RTSAA=$O(^DGS(41.1,"C",RTTM,RTSAA)) Q:'RTSAA I $D(^DGS(41.1,RTSAA,0)) S A0=^(0) D APL
K R,RTTM,RTSA,RTSAA,Q0,RTBOR,RTAA,RTBKGRD Q
APL ;A T/W,Ward,Treatsp get RTBOR pointer to Borrower
I $P(A0,"^",13) Q ;canceled
K RTBOR
S A=$P(A0,"^",10),W=$P(A0,"^",8),T=$P(A0,"^",9),DFN=+A0
;see if any sa borrowers have treat spec.
I A="T" F Z=0:0 S Z=$O(RTSA(Z)) Q:'Z I $P(RTSA(Z),"^",4)=T S RTBOR($P(RTSA(Z),"^",3))=Z
;see if any sa borrowers are ward locations
I A="W" F Z=0:0 S Z=$O(RTSA(Z)) Q:'Z I (+$P(RTSA(Z),"^",1)=W) S RTBOR($P(RTSA(Z),"^",3))=Z
;RTBOR(1),RTBOR(2) not defined, default, set default
;do directly from global
F Z="MAS","RAD" I $D(RTSA(Z)) S A=$P(RTSA(Z),"^",3) I '$D(RTBOR(A)) S RTBOR(A)=RTSA(Z)
K A,W,T,Z
I '$D(RTBOR) Q
;Now loop borrower and create request, pull list.
F RTAA=0:0 S RTAA=$O(RTBOR(RTAA)) Q:'RTAA D CREATE
Q
CREATE ;Have RTB,DFN,RTTM
;exclude inpatients
I $D(^DPT(DFN,.1)),$D(^DIC(195.1,RTAA,4)),$P(^(4),"^") Q
I $D(^DIC(195.1,RTAA,4)),$P(^(4),"^",3)="n",'$D(^RT("AA",RTAA,DFN_";DPT(")) Q
S (Y,RTB)=+RTBOR(RTAA) I 'Y Q
S Y=$P(^RTV(195.9,Y,0),"^",12) I 'Y S Y=RTB ;associated borrower
S Y=$P(^RTV(195.9,Y,0),"^") D NAME^RTB S Y="SA "_Y
;
S RTE=DFN_";DPT(",RTPLTY=1,(RTQDT,X)=RTTM,RTPN=$P(Y,"^")_" ["_$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)_"]"
PUL ;entry with RTB,RTA,Y
S X=RTB,A=+RTAA K RTA,RTSD,RTDIV D INST1^RTUTL G Q:'$D(RTINST) S RTDIV=RTINST
D BLD^RTQ2
;
I '$D(RTSD),RTAA=1 F RTBLD=0:0 S RTBLD=$O(^DIC(195.1,+^DIC(195.4,1,"MAS"),"MAS",RTBLD)) Q:'RTBLD I $D(^(RTBLD,0)) S X=^(0) D BLD1^RTQ2
;
I '$D(RTSD),RTAA=2 F RTBLD=0:0 S RTBLD=$O(^DIC(195.1,+^DIC(195.4,1,"MAS"),"RAD",RTBLD)) Q:'RTBLD I $D(^(RTBLD,0)) S X=^(0) D BLD1^RTQ2:'$D(RTTYR(+X))
D RTSD
Q K RTBLD,RTTYR,RTPAR,RTSD,RT,RTSEL,A,Z,L,L1,I,RTINST,RTDIV,RTPULL,RTPN,RTTY,RTTYP,RTAPL,RTQ,RTY,RTS,RTQDT,RTB,RTPLTY,RTE
Q
RTSD ;
K RTPAR F RT=0:0 S RT=$O(RTSD(RT)) Q:'RT S RTB=$P(^RTV(195.9,RTB,0),"^"),(RTA,RTAPL)=+RTSD(RT) D CHK K RTA,RTQ D PULL^RTQ2,CHK1 K:'$D(RTQ) RTSD(RT) I '$D(RTPAR),$D(RTQ) S RTPAR=RTQ
Q
CHK S Y=+$O(^RTV(195.9,"ABOR",RTB,RTA,0)) D SET^RTDPA3:'Y S RTB=Y Q
;
CHK1 F R=0:0 S R=$O(^RTV(190.1,"C",RTTM,R)) Q:'R I $D(^RTV(190.1,"ABOR",RTB,R)),$D(^RTV(190.1,R,0)) S Q0=^(0) I $P(Q0,"^")=RT,$P(Q0,"^",4)=RTTM,$P(Q0,"^",5)=RTB,$P(Q0,"^",10)=RTPULL Q
I 'R D SET^RTQ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTSM61 3062 printed Nov 22, 2024@17:44:49 Page 2
RTSM61 ;PKE/ISC-ALBANY more clinic requests sh. admis. ;9/1/90
+1 ;;v 2.0;Record Tracking;;10/22/91
EN FOR A=0:0
SET A=$ORDER(^RTV(195.9,"AD","y",A))
if 'A
QUIT
IF $DATA(^RTV(195.9,A,"ADM"))
IF $DATA(^(0))
SET RTSA(A)=$PIECE(^(0),"^",1,3)_"^"_$PIECE(^("ADM"),"^",2)
+1 ;
+2 IF $DATA(^DIC(195.1,+^DIC(195.4,1,"MAS"),4))
SET RTSA("MAS")=$PIECE(^(4),"^",2)_"^^"_+^DIC(195.4,1,"MAS")
+3 IF $DATA(^DIC(195.1,+^DIC(195.4,1,"RAD"),4))
SET RTSA("RAD")=$PIECE(^(4),"^",2)_"^^"_+^DIC(195.4,1,"RAD")
+4 KILL A,B
ST SET X="T"
SET %DT=""
DO ^%DT
SET RTBEG=Y
SET X="T+"_(0+$SELECT($DATA(^DIC(195.4,1,0)):$SELECT($PIECE(^(0),"^",6):$PIECE(^(0),"^",6),1:7),1:7))
DO ^%DT
SET RTEND=Y_".2359"
KILL %DT
+1 ;S RTBEG=2880101
+2 ;
START FOR RTTM=(RTBEG-.0001):0
SET RTTM=$ORDER(^DGS(41.1,"C",RTTM))
if 'RTTM!(RTEND<RTTM)
QUIT
FOR RTSAA=0:0
SET RTSAA=$ORDER(^DGS(41.1,"C",RTTM,RTSAA))
if 'RTSAA
QUIT
IF $DATA(^DGS(41.1,RTSAA,0))
SET A0=^(0)
DO APL
+1 KILL R,RTTM,RTSA,RTSAA,Q0,RTBOR,RTAA,RTBKGRD
QUIT
APL ;A T/W,Ward,Treatsp get RTBOR pointer to Borrower
+1 ;canceled
IF $PIECE(A0,"^",13)
QUIT
+2 KILL RTBOR
+3 SET A=$PIECE(A0,"^",10)
SET W=$PIECE(A0,"^",8)
SET T=$PIECE(A0,"^",9)
SET DFN=+A0
+4 ;see if any sa borrowers have treat spec.
+5 IF A="T"
FOR Z=0:0
SET Z=$ORDER(RTSA(Z))
if 'Z
QUIT
IF $PIECE(RTSA(Z),"^",4)=T
SET RTBOR($PIECE(RTSA(Z),"^",3))=Z
+6 ;see if any sa borrowers are ward locations
+7 IF A="W"
FOR Z=0:0
SET Z=$ORDER(RTSA(Z))
if 'Z
QUIT
IF (+$PIECE(RTSA(Z),"^",1)=W)
SET RTBOR($PIECE(RTSA(Z),"^",3))=Z
+8 ;RTBOR(1),RTBOR(2) not defined, default, set default
+9 ;do directly from global
+10 FOR Z="MAS","RAD"
IF $DATA(RTSA(Z))
SET A=$PIECE(RTSA(Z),"^",3)
IF '$DATA(RTBOR(A))
SET RTBOR(A)=RTSA(Z)
+11 KILL A,W,T,Z
+12 IF '$DATA(RTBOR)
QUIT
+13 ;Now loop borrower and create request, pull list.
+14 FOR RTAA=0:0
SET RTAA=$ORDER(RTBOR(RTAA))
if 'RTAA
QUIT
DO CREATE
+15 QUIT
CREATE ;Have RTB,DFN,RTTM
+1 ;exclude inpatients
+2 IF $DATA(^DPT(DFN,.1))
IF $DATA(^DIC(195.1,RTAA,4))
IF $PIECE(^(4),"^")
QUIT
+3 IF $DATA(^DIC(195.1,RTAA,4))
IF $PIECE(^(4),"^",3)="n"
IF '$DATA(^RT("AA",RTAA,DFN_";DPT("))
QUIT
+4 SET (Y,RTB)=+RTBOR(RTAA)
IF 'Y
QUIT
+5 ;associated borrower
SET Y=$PIECE(^RTV(195.9,Y,0),"^",12)
IF 'Y
SET Y=RTB
+6 SET Y=$PIECE(^RTV(195.9,Y,0),"^")
DO NAME^RTB
SET Y="SA "_Y
+7 ;
+8 SET RTE=DFN_";DPT("
SET RTPLTY=1
SET (RTQDT,X)=RTTM
SET RTPN=$PIECE(Y,"^")_" ["_$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)_"]"
PUL ;entry with RTB,RTA,Y
+1 SET X=RTB
SET A=+RTAA
KILL RTA,RTSD,RTDIV
DO INST1^RTUTL
if '$DATA(RTINST)
GOTO Q
SET RTDIV=RTINST
+2 DO BLD^RTQ2
+3 ;
+4 IF '$DATA(RTSD)
IF RTAA=1
FOR RTBLD=0:0
SET RTBLD=$ORDER(^DIC(195.1,+^DIC(195.4,1,"MAS"),"MAS",RTBLD))
if 'RTBLD
QUIT
IF $DATA(^(RTBLD,0))
SET X=^(0)
DO BLD1^RTQ2
+5 ;
+6 IF '$DATA(RTSD)
IF RTAA=2
FOR RTBLD=0:0
SET RTBLD=$ORDER(^DIC(195.1,+^DIC(195.4,1,"MAS"),"RAD",RTBLD))
if 'RTBLD
QUIT
IF $DATA(^(RTBLD,0))
SET X=^(0)
if '$DATA(RTTYR(+X))
DO BLD1^RTQ2
+7 DO RTSD
Q KILL RTBLD,RTTYR,RTPAR,RTSD,RT,RTSEL,A,Z,L,L1,I,RTINST,RTDIV,RTPULL,RTPN,RTTY,RTTYP,RTAPL,RTQ,RTY,RTS,RTQDT,RTB,RTPLTY,RTE
+1 QUIT
RTSD ;
+1 KILL RTPAR
FOR RT=0:0
SET RT=$ORDER(RTSD(RT))
if 'RT
QUIT
SET RTB=$PIECE(^RTV(195.9,RTB,0),"^")
SET (RTA,RTAPL)=+RTSD(RT)
DO CHK
KILL RTA,RTQ
DO PULL^RTQ2
DO CHK1
if '$DATA(RTQ)
KILL RTSD(RT)
IF '$DATA(RTPAR)
IF $DATA(RTQ)
SET RTPAR=RTQ
+2 QUIT
CHK SET Y=+$ORDER(^RTV(195.9,"ABOR",RTB,RTA,0))
if 'Y
DO SET^RTDPA3
SET RTB=Y
QUIT
+1 ;
CHK1 FOR R=0:0
SET R=$ORDER(^RTV(190.1,"C",RTTM,R))
if 'R
QUIT
IF $DATA(^RTV(190.1,"ABOR",RTB,R))
IF $DATA(^RTV(190.1,R,0))
SET Q0=^(0)
IF $PIECE(Q0,"^")=RT
IF $PIECE(Q0,"^",4)=RTTM
IF $PIECE(Q0,"^",5)=RTB
IF $PIECE(Q0,"^",10)=RTPULL
QUIT
+1 IF 'R
DO SET^RTQ
+2 QUIT
