- DGA4004 ;ALB/MRL - AMIS 420 ACTUAL GENERATION OF REPORTS ;01 JAN 1988@2300
- ;;5.3;Registration;**41,1015**;Aug 13, 1993;Build 21
- ;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
- DGA4004 ;ALB/MRL - AMIS 420 ACTUAL GENERATION OF REPORTS ;01 JAN 1988@2300
- +1 ;;5.3;Registration;**41,1015**;Aug 13, 1993;Build 21
- +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
