DGOIL3 ;ALB/AAS - CALC LOS BY TRANSFER (CONT), GET ASIH MOVEMENTS ; 23-OCT-90
;;5.3;Registration;;Aug 13, 1993
;
SAVE ;variables needing saving
S DGPMIFN(1)=DGPMIFN,DGPMIFN1(1)=DGPMIFN1,A(1)=A,A1(1)=A1,D(1)=D,I(1)=I,B("SAVE")=B
K DGS
;
SET ;set up new variables needed
S I=1,DGT=DGT+1,X(DGT)="0^0^0^0^0^0^0"
S DGPMIFN=$S('Z:"",'$D(^DGPM(+Z,0)):"",1:$P(^(0),"^",15)) G RESTORE:'DGPMIFN G RESTORE:'$D(^DGPM(DGPMIFN,0)) S B=^DGPM(DGPMIFN,0) S A=$S($L(+B)>7:+B,1:+B_"."),A=$E(A_"000000",1,14)_$P(B,"^",22)
D MAX^DGOIL2 ;set d equal to discharge
;
CALC ;find ASIH movements
D ADM^DGOIL2
;
RESTORE ;set variables back to original
S A=D+.0000002 ;start with movement after discharge date
S DGPMIFN=DGPMIFN(1),DGPMIFN1=DGPMIFN1(1),A1=A1(1),D=D(1),I=I(1),B=B("SAVE")
;
END K DGPMIFN(1),DGPMIFN1(1),A(1),A1(1),D(1),I(1),B("SAVE"),DGDONE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGOIL3 865 printed Dec 13, 2024@02:46:36 Page 2
DGOIL3 ;ALB/AAS - CALC LOS BY TRANSFER (CONT), GET ASIH MOVEMENTS ; 23-OCT-90
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
SAVE ;variables needing saving
+1 SET DGPMIFN(1)=DGPMIFN
SET DGPMIFN1(1)=DGPMIFN1
SET A(1)=A
SET A1(1)=A1
SET D(1)=D
SET I(1)=I
SET B("SAVE")=B
+2 KILL DGS
+3 ;
SET ;set up new variables needed
+1 SET I=1
SET DGT=DGT+1
SET X(DGT)="0^0^0^0^0^0^0"
+2 SET DGPMIFN=$SELECT('Z:"",'$DATA(^DGPM(+Z,0)):"",1:$PIECE(^(0),"^",15))
if 'DGPMIFN
GOTO RESTORE
if '$DATA(^DGPM(DGPMIFN,0))
GOTO RESTORE
SET B=^DGPM(DGPMIFN,0)
SET A=$SELECT($LENGTH(+B)>7:+B,1:+B_".")
SET A=$EXTRACT(A_"000000",1,14)_$PIECE(B,"^",22)
+3 ;set d equal to discharge
DO MAX^DGOIL2
+4 ;
CALC ;find ASIH movements
+1 DO ADM^DGOIL2
+2 ;
RESTORE ;set variables back to original
+1 ;start with movement after discharge date
SET A=D+.0000002
+2 SET DGPMIFN=DGPMIFN(1)
SET DGPMIFN1=DGPMIFN1(1)
SET A1=A1(1)
SET D=D(1)
SET I=I(1)
SET B=B("SAVE")
+3 ;
END KILL DGPMIFN(1),DGPMIFN1(1),A(1),A1(1),D(1),I(1),B("SAVE"),DGDONE
+1 QUIT
