DGPMVBUL ;ALB/MIR/MAC - SEND MOVEMENT BULLITENS; 12 Sep 1989
;;5.3;Registration;;Aug 13, 1993
;
;send UR admission bulletin
D ^DGPMVBUR
;
;Send Unverified Eligibility Bulletin
Q:'$D(DFN) D ^DGPATV S DGB=$S('DGVETS:7,'$D(^DPT(DFN,.361)):0,$P(^DPT(DFN,.361),"^",1)'="V":5,1:0) G EN:'DGB
D INFO
I '$D(DGPMDA) G EN
S DGADMIT=$S($D(^DGPM(DGPMDA,0)):^(0),1:"") G EN:'DGADMIT S Y=+DGADMIT X ^DD("DD") S DGTEXT(DGC,0)="ADMITTED: "_Y,DGC=DGC+1
S DGTEXT(DGC,0)=" TYPE: "_$S($D(^DG(405.1,+$P(DGADMIT,"^",4),0)):$P(^(0),"^",1),1:"UNKNOWN"),DGC=DGC+1,DGTEXT(DGC,0)=" WARD: "_$S($D(^DIC(42,+$P(DGADMIT,"^",6),0)):$P(^(0),"^",1),1:"UNKNOWN")
I DGB=5 S DGC=DGC+1,DGTEXT(DGC,0)="",DGC=DGC+1,DGTEXT(DGC,0)="Veterans eligibility has not been verified yet." S DGC=DGC+1,DGTEXT(DGC,0)=""
EN S DGFL=0 F DGI=0:0 S DGI=$O(^DGS(41.1,"B",DFN,DGI)) Q:'DGI S J=$S($D(^DGS(41.1,DGI,0)):^(0),1:0),Y=$P(J,"^",2) I Y X ^DD("DD") I '$P(J,"^",13),'$P(J,"^",17) D WR
S DGFL=0 F X=0:0 S X=$O(^DGWAIT("C",DFN,X)) Q:'X S Y=$O(^(+X,0)) G T:('X)!('Y) I $D(^DGWAIT(X,"P",Y,0)) S I=^(0) D:'DGFL TEXT S DGC=DGC+1,DGG=$S($D(^DG(40.8,+^DGWAIT(X,0),0)):$E($P(^(0),"^",1),1,20),1:"") D CO
T G Q:'$D(DGTEXT) S DGB=$S(DGB:DGB,1:5) D ^DGBUL
Q K DGADMIT,DGB,DGC,DGFL,DGG,DGI,I,J,X,Y D KILL^DGPATV Q
Q
INFO I $D(DGC) S DGC=DGC+1 Q
S XMSUB=$S('DGVETS:"NON-VETERAN ADMISSION",DGB=0:"FUTURE ACTIVITY SCHEDULED",1:"VETERAN ADMISSION WITHOUT VERIFIED ELIGIBILITY")
S DGTEXT(1,0)="NAME: "_DGNAME,DGTEXT(2,0)="SSN : "_$P(SSN,"^",2),DGTEXT(3,0)="DOB : "_$P(DOB,"^",2),DGTEXT(4,0)="ELIG: "_$P(DGEC,"^",2)
S DGC=5,DGTEXT(DGC,0)="",DGC=DGC+1
Q
WR I 'DGFL D INFO S DGTEXT(DGC,0)="This patient has the following Scheduled Admissions on file:" S DGFL=1
S DGC=DGC+1,DGTEXT(DGC,0)=" DATE: "_Y_" "_$S($P(J,"^",10)="W":"WARD: "_$S($D(^DIC(42,+$P(J,"^",8),0)):$P(^(0),"^",1),1:""),$P(J,"^",10)="T":"FACILITY TREATING SPECIALTY: "_$S($D(^DIC(45.7,+$P(J,"^",9),0)):$P(^(0),"^",1),1:""),1:"") Q
Q
TEXT D INFO S:'DGFL DGTEXT(DGC,0)="This patient has the following waiting list entries:" S DGFL=1 Q
CO S Y=$P(I,"^",2) X ^DD("DD") S DGTEXT(DGC,0)=" TO: "_DGG_" APPLIED: "_Y_" BEDSECTION: "_$P(I,"^",5) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMVBUL 2213 printed Dec 13, 2024@02:50:24 Page 2
DGPMVBUL ;ALB/MIR/MAC - SEND MOVEMENT BULLITENS; 12 Sep 1989
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
+3 ;send UR admission bulletin
+4 DO ^DGPMVBUR
+5 ;
+6 ;Send Unverified Eligibility Bulletin
+7 if '$DATA(DFN)
QUIT
DO ^DGPATV
SET DGB=$SELECT('DGVETS:7,'$DATA(^DPT(DFN,.361)):0,$PIECE(^DPT(DFN,.361),"^",1)'="V":5,1:0)
if 'DGB
GOTO EN
+8 DO INFO
+9 IF '$DATA(DGPMDA)
GOTO EN
+10 SET DGADMIT=$SELECT($DATA(^DGPM(DGPMDA,0)):^(0),1:"")
if 'DGADMIT
GOTO EN
SET Y=+DGADMIT
XECUTE ^DD("DD")
SET DGTEXT(DGC,0)="ADMITTED: "_Y
SET DGC=DGC+1
+11 SET DGTEXT(DGC,0)=" TYPE: "_$SELECT($DATA(^DG(405.1,+$PIECE(DGADMIT,"^",4),0)):$PIECE(^(0),"^",1),1:"UNKNOWN")
SET DGC=DGC+1
SET DGTEXT(DGC,0)=" WARD: "_$SELECT($DATA(^DIC(42,+$PIECE(DGADMIT,"^",6),0)):$PIECE(^(0),"^",1),1:"UNKNOWN")
+12 IF DGB=5
SET DGC=DGC+1
SET DGTEXT(DGC,0)=""
SET DGC=DGC+1
SET DGTEXT(DGC,0)="Veterans eligibility has not been verified yet."
SET DGC=DGC+1
SET DGTEXT(DGC,0)=""
EN SET DGFL=0
FOR DGI=0:0
SET DGI=$ORDER(^DGS(41.1,"B",DFN,DGI))
if 'DGI
QUIT
SET J=$SELECT($DATA(^DGS(41.1,DGI,0)):^(0),1:0)
SET Y=$PIECE(J,"^",2)
IF Y
XECUTE ^DD("DD")
IF '$PIECE(J,"^",13)
IF '$PIECE(J,"^",17)
DO WR
+1 SET DGFL=0
FOR X=0:0
SET X=$ORDER(^DGWAIT("C",DFN,X))
if 'X
QUIT
SET Y=$ORDER(^(+X,0))
if ('X)!('Y)
GOTO T
IF $DATA(^DGWAIT(X,"P",Y,0))
SET I=^(0)
if 'DGFL
DO TEXT
SET DGC=DGC+1
SET DGG=$SELECT($DATA(^DG(40.8,+^DGWAIT(X,0),0)):$EXTRACT($PIECE(^(0),"^",1),1,20),1:"")
DO CO
T if '$DATA(DGTEXT)
GOTO Q
SET DGB=$SELECT(DGB:DGB,1:5)
DO ^DGBUL
Q KILL DGADMIT,DGB,DGC,DGFL,DGG,DGI,I,J,X,Y
DO KILL^DGPATV
QUIT
+1 QUIT
INFO IF $DATA(DGC)
SET DGC=DGC+1
QUIT
+1 SET XMSUB=$SELECT('DGVETS:"NON-VETERAN ADMISSION",DGB=0:"FUTURE ACTIVITY SCHEDULED",1:"VETERAN ADMISSION WITHOUT VERIFIED ELIGIBILITY")
+2 SET DGTEXT(1,0)="NAME: "_DGNAME
SET DGTEXT(2,0)="SSN : "_$PIECE(SSN,"^",2)
SET DGTEXT(3,0)="DOB : "_$PIECE(DOB,"^",2)
SET DGTEXT(4,0)="ELIG: "_$PIECE(DGEC,"^",2)
+3 SET DGC=5
SET DGTEXT(DGC,0)=""
SET DGC=DGC+1
+4 QUIT
WR IF 'DGFL
DO INFO
SET DGTEXT(DGC,0)="This patient has the following Scheduled Admissions on file:"
SET DGFL=1
+1 SET DGC=DGC+1
SET DGTEXT(DGC,0)=" DATE: "_Y_" "_$SELECT($PIECE(J,"^",10)="W":"WARD: "_$SELECT($DATA(^DIC(42,+$PIECE(J,"^",8),0)):...
... $PIECE(^(0),"^",1),1:""),$PIECE(J,"^",10)="T":"FACILITY TREATING SPECIALTY: "_$SELECT($DATA(^DIC(45.7,+$PIECE(J,"^",9),0)):$PIECE(^(0),"^",1),1:""),1:"")
QUIT
+2 QUIT
TEXT DO INFO
if 'DGFL
SET DGTEXT(DGC,0)="This patient has the following waiting list entries:"
SET DGFL=1
QUIT
CO SET Y=$PIECE(I,"^",2)
XECUTE ^DD("DD")
SET DGTEXT(DGC,0)=" TO: "_DGG_" APPLIED: "_Y_" BEDSECTION: "_$PIECE(I,"^",5)
QUIT
