DGA4004 ;ALB/MRL - AMIS 420 ACTUAL GENERATION OF REPORTS ;01 JAN 1988@2300
;;5.3;Registration;**41**;Aug 13, 1993
;S IOP=$S($D(ION):ION,1:IO)_";132" D ^%ZIS K IOP I IO=DGDEV W !!,"===> Collecting AMIS 401-420 Statistics..."
I IO=DGDEV W !!,"===> Collecting AMIS 401-420 Statistics..."
D DEL^DGA4003 K ^UTILITY($J,"DGSEG"),^("DGSEGP") D DIV^DGUTL
S DGDV=DGDIV F DFN=0:0 S DFN=$O(^UTILITY($J,"DGDIS",DFN)) Q:'DFN F DGREG=0:0 S DGREG=$O(^UTILITY($J,"DGDIS",DFN,DGREG)) Q:'DGREG S DGDATA=^(DGREG),DGDISLO=$P(DGDATA,"^",6) D REP
I $D(^UTILITY($J,"DGSEG")) W:IO=DGDEV !!,"===> Storing Data in 'AMIS SEGMENT' file..." G SAV^DGA4005
G QUIT^DGA4002
REP S (DGSEG,DGSEGR)="" I $P(DGDATA,"^",17),$P(DGDATA,"^",17)<418 S DGSEG=$P(DGDATA,"^",17)
S X1=$S($D(^DIC(8,+$P(DGDATA,"^",13),0)):$P(^(0),"^",5),1:"") I X1'="Y" S DGSEG=420,DGSEGR="NV"
I 'DGSEG S DGXXXD=1,DGDATA1=DGDATA D SEG1
I 'DGDIV S I=$P(DGDATA,"^",4) D DV^DGA4001
S DGBLK="",DGX=$S($D(^DIC(37,+$P(DGDATA,"^",7),0)):^(0),1:""),DGX1=+$P(DGX,"^",9),DGBLK=$S(DGSEGR="NV":40,DGX']"":8,'DGX1:8,1:"") I DGBLK G GOTIT
I "^TRT^INE^LOW^"'[("^"_$E(DGX,1,3)_"^") S DGBLK=DGBLK_$P("10^8^6^7^8^2^3^4^5^9^8^8^38^8^39","^",DGX1)_"^" G GOTIT
S DGX2=+$P(DGDATA,"^",3),DGX2=$S(DGX2=1:1,DGX2=2:3,DGX2=5:2,1:4) I "^INE^"[("^"_$E(DGX,1,3)_"^") S DGX3=+$P(DGDATA,"^",11),DGBLK=DGBLK_(DGX3+10)_"^"_(DGX2+15)_"^"_$S(DGX1=2:20,1:21)_"^" G GOTIT
I "^TRT^"[("^"_$E(DGX,1,3)_"^") S DGBLK=DGBLK_(DGX2+21)_"^"_$S(DGX1=2:26,DGX1=14:27,DGX1=5:28,1:29)_"^" G GOTIT
S DGBLK=DGBLK_(DGX2+29)_"^"_$S(DGX1=2:34,DGX1=14:35,DGX1=5:36,1:37)_"^"
GOTIT S DGBLK="1^"_DGBLK,DGN1="",DGN=$S($D(^UTILITY($J,"DGSEG",DGSEG,+DGDV)):^(+DGDV),1:"") F I=1:1 S J=$P(DGBLK,"^",I) Q:J="" S $P(DGN,"^",J)=$P(DGN,"^",J)+1 I J>1 S DGN1=DGN1_$S(J<10:"0"_J,1:J)_","
W:IO=DGDEV "." S ^UTILITY($J,"DGSEG",DGSEG,+DGDV)=DGN Q:'DGAL
S X=$S($D(^DPT(DFN,0)):^(0),1:""),X1=$S($P(X,"^",1)'="":$P(X,"^",1),1:"PATIENT #"_DFN),X2=$E($P(X1,",",1)_","_$E(X1,$F(X1,",")),1,15),$P(DGN1,"^",2)=$E($P(X,"^",9),6,9)_"^"_$S($D(^DIC(8,+$P(DGDATA,"^",13),0)):$P(^(0),"^",6),1:"UNKNOWN")
S $P(DGN1,"^",4)=$S($P(DGDATA,"^",3)=1:"Hosp Care",$P(DGDATA,"^",3)=2:"Dom Care",$P(DGDATA,"^",3)=3:"OP Medical",$P(DGDATA,"^",3)=4:"OP Dental",$P(DGDATA,"^",3)=5:"NHCU Care",1:"Unknown"),$P(DGN1,"^",5)=$E(DGX,1,30)
S ^UTILITY($J,"DGSEGP",+DGDV,DGSEG,X2,+DGDATA)=DGN1 Q
SEG ;Determine Segment to count patient in
S DGSEG="",DGDATA1=$S($D(^DPT(DFN,"DIS",DFN1,0)):^(0),1:"") Q:'DGDATA1
SEG1 S DGSEGR="" G SEG2:'$P(DGDATA1,"^",15) S X=$P(DGDATA1,"^",16) I X']""!(X#10) S DGSEG=412 G SEGQ
I 'X S DGSEG=411 G SEGQ
S X=X/10,DGSEG=$P("410^409^408^407^406^405^404^403^402^401","^",X) G SEGQ
SEG2 S X1=$S($D(^DIC(8,+$P(DGDATA1,"^",13),0)):$P(^(0),"^",5),1:"") I X1'="Y" S DGSEGR="NV",DGSEG=420 G SEGQ
S X=$S($D(^DIC(8,+$P(DGDATA1,"^",13),0)):$P(^(0),"^",9),1:"") I X']"" G CAT:DGXXXD,SEGQ
I X=18 S DGSEG=413 G SEGQ
S X1=$S($D(^DPT(DFN,.321)):^(.321),1:"") I $P(X1,"^",2)="Y"!($P(X1,"^",3)="Y") S DGSEG=414 G SEGQ
I X=16!(X=17) S DGSEG=415 G SEGQ
I X=4 S DGSEG=416 G SEGQ
I $P($G(^DPT(DFN,.38)),U) S DGSEG=417 G SEGQ
G SEGQ:'DGXXXD
CAT ;Determine Category for others
I '$D(^DGMT(408.31,"AD",1,DFN)) S DGSEGR="NM",DGSEG=418 G SEGQ
S DGLSTMN=$P($$LST^DGMTU(DFN,+DGDISLO),U,4)
I DGLSTMN']"" S DGSEGR="NT",DGSEG=418 G SEGQ
S DGSEG=$S(DGLSTMN="B":419,"CP"[DGLSTMN:420,1:418),DGSEGR=DGLSTMN
SEGQ K DGZ,DGZ1,DGZ2,X,X1,DGDATA1,DGLSTMN I 'DGXXXD K DGSEGR Q
I $D(DGSEG),$D(^DPT(DFN,"DIS",DGREG,0)) S $P(^(0),"^",17)=DGSEG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGA4004 3536 printed Apr 09, 2024@21:55:33 Page 2
DGA4004 ;ALB/MRL - AMIS 420 ACTUAL GENERATION OF REPORTS ;01 JAN 1988@2300
+1 ;;5.3;Registration;**41**;Aug 13, 1993
+2 ;S IOP=$S($D(ION):ION,1:IO)_";132" D ^%ZIS K IOP I IO=DGDEV W !!,"===> Collecting AMIS 401-420 Statistics..."
+3 IF IO=DGDEV
WRITE !!,"===> Collecting AMIS 401-420 Statistics..."
+4 DO DEL^DGA4003
KILL ^UTILITY($JOB,"DGSEG"),^("DGSEGP")
DO DIV^DGUTL
+5 SET DGDV=DGDIV
FOR DFN=0:0
SET DFN=$ORDER(^UTILITY($JOB,"DGDIS",DFN))
if 'DFN
QUIT
FOR DGREG=0:0
SET DGREG=$ORDER(^UTILITY($JOB,"DGDIS",DFN,DGREG))
if 'DGREG
QUIT
SET DGDATA=^(DGREG)
SET DGDISLO=$PIECE(DGDATA,"^",6)
DO REP
+6 IF $DATA(^UTILITY($JOB,"DGSEG"))
if IO=DGDEV
WRITE !!,"===> Storing Data in 'AMIS SEGMENT' file..."
GOTO SAV^DGA4005
+7 GOTO QUIT^DGA4002
REP SET (DGSEG,DGSEGR)=""
IF $PIECE(DGDATA,"^",17)
IF $PIECE(DGDATA,"^",17)<418
SET DGSEG=$PIECE(DGDATA,"^",17)
+1 SET X1=$SELECT($DATA(^DIC(8,+$PIECE(DGDATA,"^",13),0)):$PIECE(^(0),"^",5),1:"")
IF X1'="Y"
SET DGSEG=420
SET DGSEGR="NV"
+2 IF 'DGSEG
SET DGXXXD=1
SET DGDATA1=DGDATA
DO SEG1
+3 IF 'DGDIV
SET I=$PIECE(DGDATA,"^",4)
DO DV^DGA4001
+4 SET DGBLK=""
SET DGX=$SELECT($DATA(^DIC(37,+$PIECE(DGDATA,"^",7),0)):^(0),1:"")
SET DGX1=+$PIECE(DGX,"^",9)
SET DGBLK=$SELECT(DGSEGR="NV":40,DGX']"":8,'DGX1:8,1:"")
IF DGBLK
GOTO GOTIT
+5 IF "^TRT^INE^LOW^"'[("^"_$EXTRACT(DGX,1,3)_"^")
SET DGBLK=DGBLK_$PIECE("10^8^6^7^8^2^3^4^5^9^8^8^38^8^39","^",DGX1)_"^"
GOTO GOTIT
+6 SET DGX2=+$PIECE(DGDATA,"^",3)
SET DGX2=$SELECT(DGX2=1:1,DGX2=2:3,DGX2=5:2,1:4)
IF "^INE^"[("^"_$EXTRACT(DGX,1,3)_"^")
SET DGX3=+$PIECE(DGDATA,"^",11)
SET DGBLK=DGBLK_(DGX3+10)_"^"_(DGX2+15)_"^"_$SELECT(DGX1=2:20,1:21)_"^"
GOTO GOTIT
+7 IF "^TRT^"[("^"_$EXTRACT(DGX,1,3)_"^")
SET DGBLK=DGBLK_(DGX2+21)_"^"_$SELECT(DGX1=2:26,DGX1=14:27,DGX1=5:28,1:29)_"^"
GOTO GOTIT
+8 SET DGBLK=DGBLK_(DGX2+29)_"^"_$SELECT(DGX1=2:34,DGX1=14:35,DGX1=5:36,1:37)_"^"
GOTIT SET DGBLK="1^"_DGBLK
SET DGN1=""
SET DGN=$SELECT($DATA(^UTILITY($JOB,"DGSEG",DGSEG,+DGDV)):^(+DGDV),1:"")
FOR I=1:1
SET J=$PIECE(DGBLK,"^",I)
if J=""
QUIT
SET $PIECE(DGN,"^",J)=$PIECE(DGN,"^",J)+1
IF J>1
SET DGN1=DGN1_$SELECT(J<10:"0"_J,1:J)_","
+1 if IO=DGDEV
WRITE "."
SET ^UTILITY($JOB,"DGSEG",DGSEG,+DGDV)=DGN
if 'DGAL
QUIT
+2 SET X=$SELECT($DATA(^DPT(DFN,0)):^(0),1:"")
SET X1=$SELECT($PIECE(X,"^",1)'="":$PIECE(X,"^",1),1:"PATIENT #"_DFN)
SET X2=$EXTRACT($PIECE(X1,",",1)_","_$EXTRACT(X1,$FIND(X1,",")),1,15)
SET $PIECE(DGN1,"^",2)=$EXTRACT($PIECE(X,"^",9),6,9)_"^"_$SELECT($DATA(^DIC(8,+$PIECE(DGDATA,"^",13),0)):$PIECE(^(0),"^",6),1:"UNKNOWN")
+3 SET $PIECE(DGN1,"^",4)=$SELECT($PIECE(DGDATA,"^",3)=1:"Hosp Care",$PIECE(DGDATA,"^",3)=2:"Dom Care",$PIECE(DGDATA,"^",3)=3:"OP Medical",$PIECE(DGDATA,"^",3)=4:"OP Dental",$PIECE(DGDATA,"^",3)=5:"NHCU Care",1:"Unknown")
SET $PIECE(DGN1,"^",5)=$EXTRACT(DGX,1,30)
+4 SET ^UTILITY($JOB,"DGSEGP",+DGDV,DGSEG,X2,+DGDATA)=DGN1
QUIT
SEG ;Determine Segment to count patient in
+1 SET DGSEG=""
SET DGDATA1=$SELECT($DATA(^DPT(DFN,"DIS",DFN1,0)):^(0),1:"")
if 'DGDATA1
QUIT
SEG1 SET DGSEGR=""
if '$PIECE(DGDATA1,"^",15)
GOTO SEG2
SET X=$PIECE(DGDATA1,"^",16)
IF X']""!(X#10)
SET DGSEG=412
GOTO SEGQ
+1 IF 'X
SET DGSEG=411
GOTO SEGQ
+2 SET X=X/10
SET DGSEG=$PIECE("410^409^408^407^406^405^404^403^402^401","^",X)
GOTO SEGQ
SEG2 SET X1=$SELECT($DATA(^DIC(8,+$PIECE(DGDATA1,"^",13),0)):$PIECE(^(0),"^",5),1:"")
IF X1'="Y"
SET DGSEGR="NV"
SET DGSEG=420
GOTO SEGQ
+1 SET X=$SELECT($DATA(^DIC(8,+$PIECE(DGDATA1,"^",13),0)):$PIECE(^(0),"^",9),1:"")
IF X']""
if DGXXXD
GOTO CAT
GOTO SEGQ
+2 IF X=18
SET DGSEG=413
GOTO SEGQ
+3 SET X1=$SELECT($DATA(^DPT(DFN,.321)):^(.321),1:"")
IF $PIECE(X1,"^",2)="Y"!($PIECE(X1,"^",3)="Y")
SET DGSEG=414
GOTO SEGQ
+4 IF X=16!(X=17)
SET DGSEG=415
GOTO SEGQ
+5 IF X=4
SET DGSEG=416
GOTO SEGQ
+6 IF $PIECE($GET(^DPT(DFN,.38)),U)
SET DGSEG=417
GOTO SEGQ
+7 if 'DGXXXD
GOTO SEGQ
CAT ;Determine Category for others
+1 IF '$DATA(^DGMT(408.31,"AD",1,DFN))
SET DGSEGR="NM"
SET DGSEG=418
GOTO SEGQ
+2 SET DGLSTMN=$PIECE($$LST^DGMTU(DFN,+DGDISLO),U,4)
+3 IF DGLSTMN']""
SET DGSEGR="NT"
SET DGSEG=418
GOTO SEGQ
+4 SET DGSEG=$SELECT(DGLSTMN="B":419,"CP"[DGLSTMN:420,1:418)
SET DGSEGR=DGLSTMN
SEGQ KILL DGZ,DGZ1,DGZ2,X,X1,DGDATA1,DGLSTMN
IF 'DGXXXD
KILL DGSEGR
QUIT
+1 IF $DATA(DGSEG)
IF $DATA(^DPT(DFN,"DIS",DGREG,0))
SET $PIECE(^(0),"^",17)=DGSEG
+2 QUIT
