A1B2MSP ;ALB/AAS - UTILITY TO SET BEDSECTIONSAND LOS FROM PTF ; 16-JAN-91
;;Version 1.55 (local for MAS v5 sites);;
;
% ;setup variables -
K ^UTILITY($J)
;
1 ;build array of movement dates, billable specialties
S A1B2MVMT=0 F A1B2I=0:0 S A1B2MVMT=$O(^DGPT(A1B2PTF,"M",A1B2MVMT)) Q:'A1B2MVMT D SETU
;
2 ;build array of billable specialties = los in specialties
; -- ptf record is closed, use all movements
S (A1B2MVDT,A1B2MVDP)=$P(^DGPT(A1B2PTF,0),"^",2)
S A1B2MVDT="" F I=0:0 S A1B2MVDT=$O(^UTILITY($J,"A1B2-PTF",A1B2MVDT)) Q:'A1B2MVDT D SETU1 S A1B2MVDP=A1B2MVDT
;
3 ;find specialties and set up in file.
S A1B2BS=""
F A1B2I=0:0 S A1B2BS=$O(^UTILITY($J,"A1B2-BS",A1B2BS)) Q:A1B2BS']"" S A1B2LOS=^(A1B2BS),A1B2BSI=$O(^DGCR(399.1,"B",A1B2BS,0)) I A1B2BSI,$D(^DGCR(399.1,A1B2BSI,0)) D STORE
G END
SETU ;utility array of all movements by date, billing specialty
S X=^DGPT(A1B2PTF,"M",A1B2MVMT,0)
S A1B2SPC=$S('$P(X,U,2):"UNKNOWN",$D(^DIC(42.4,$P(X,U,2),0)):$P(^(0),U,5),1:"UNKNOWN") Q:A1B2SPC=""
S ^UTILITY($J,"A1B2-PTF",$S($P(X,U,10)]"":$P(X,U,10),1:DT),A1B2SPC)=$P(X,U,3)+$P(X,U,4)
Q
SETU1 ;determine los - set utility=los
S X1=A1B2MVDT,X2=A1B2MVDP D ^%DTC S A1B2BS=$O(^UTILITY($J,"A1B2-PTF",A1B2MVDT,0)),A1B2PASS=^(A1B2BS)
S:((A1B2MVDP\1)=(A1B2MVDT\1)) X=1
Q:((X-A1B2PASS)<1)
I '$D(^UTILITY($J,"A1B2-BS",A1B2BS)) S ^UTILITY($J,"A1B2-BS",A1B2BS)=X-A1B2PASS Q
S ^(A1B2BS)=^UTILITY($J,"A1B2-BS",A1B2BS)+(X-A1B2PASS)
Q
STORE ;store bedsection and los in 11500.61
S A1B2FL=11500.61,A1B2DT=A1B2BSI
D ADD^A1B2UTL
S DA=+Y,DR="[A1B2 SPECIALTY STUFF]",DIE="^A1B2(11500.61," D ^DIE
Q
;
END ;K ^UTILITY($J)
;K A1B2EDT,A1B2MVMT,A1B2BS,A1B2BSI,A1B2LOS,A1B2MVDT,A1B2MVDP,A1B2SPC,A1B2PASS,A1B2I,X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HA1B2MSP 1753 printed Dec 13, 2024@02:21:12 Page 2
A1B2MSP ;ALB/AAS - UTILITY TO SET BEDSECTIONSAND LOS FROM PTF ; 16-JAN-91
+1 ;;Version 1.55 (local for MAS v5 sites);;
+2 ;
% ;setup variables -
+1 KILL ^UTILITY($JOB)
+2 ;
1 ;build array of movement dates, billable specialties
+1 SET A1B2MVMT=0
FOR A1B2I=0:0
SET A1B2MVMT=$ORDER(^DGPT(A1B2PTF,"M",A1B2MVMT))
if 'A1B2MVMT
QUIT
DO SETU
+2 ;
2 ;build array of billable specialties = los in specialties
+1 ; -- ptf record is closed, use all movements
+2 SET (A1B2MVDT,A1B2MVDP)=$PIECE(^DGPT(A1B2PTF,0),"^",2)
+3 SET A1B2MVDT=""
FOR I=0:0
SET A1B2MVDT=$ORDER(^UTILITY($JOB,"A1B2-PTF",A1B2MVDT))
if 'A1B2MVDT
QUIT
DO SETU1
SET A1B2MVDP=A1B2MVDT
+4 ;
3 ;find specialties and set up in file.
+1 SET A1B2BS=""
+2 FOR A1B2I=0:0
SET A1B2BS=$ORDER(^UTILITY($JOB,"A1B2-BS",A1B2BS))
if A1B2BS']""
QUIT
SET A1B2LOS=^(A1B2BS)
SET A1B2BSI=$ORDER(^DGCR(399.1,"B",A1B2BS,0))
IF A1B2BSI
IF $DATA(^DGCR(399.1,A1B2BSI,0))
DO STORE
+3 GOTO END
SETU ;utility array of all movements by date, billing specialty
+1 SET X=^DGPT(A1B2PTF,"M",A1B2MVMT,0)
+2 SET A1B2SPC=$SELECT('$PIECE(X,U,2):"UNKNOWN",$DATA(^DIC(42.4,$PIECE(X,U,2),0)):$PIECE(^(0),U,5),1:"UNKNOWN")
if A1B2SPC=""
QUIT
+3 SET ^UTILITY($JOB,"A1B2-PTF",$SELECT($PIECE(X,U,10)]"":$PIECE(X,U,10),1:DT),A1B2SPC)=$PIECE(X,U,3)+$PIECE(X,U,4)
+4 QUIT
SETU1 ;determine los - set utility=los
+1 SET X1=A1B2MVDT
SET X2=A1B2MVDP
DO ^%DTC
SET A1B2BS=$ORDER(^UTILITY($JOB,"A1B2-PTF",A1B2MVDT,0))
SET A1B2PASS=^(A1B2BS)
+2 if ((A1B2MVDP\1)=(A1B2MVDT\1))
SET X=1
+3 if ((X-A1B2PASS)<1)
QUIT
+4 IF '$DATA(^UTILITY($JOB,"A1B2-BS",A1B2BS))
SET ^UTILITY($JOB,"A1B2-BS",A1B2BS)=X-A1B2PASS
QUIT
+5 SET ^(A1B2BS)=^UTILITY($JOB,"A1B2-BS",A1B2BS)+(X-A1B2PASS)
+6 QUIT
STORE ;store bedsection and los in 11500.61
+1 SET A1B2FL=11500.61
SET A1B2DT=A1B2BSI
+2 DO ADD^A1B2UTL
+3 SET DA=+Y
SET DR="[A1B2 SPECIALTY STUFF]"
SET DIE="^A1B2(11500.61,"
DO ^DIE
+4 QUIT
+5 ;
END ;K ^UTILITY($J)
+1 ;K A1B2EDT,A1B2MVMT,A1B2BS,A1B2BSI,A1B2LOS,A1B2MVDT,A1B2MVDP,A1B2SPC,A1B2PASS,A1B2I,X
