- DGPMVBUL ;ALB/MIR/MAC - SEND MOVEMENT BULLITENS; 12 Sep 1989
- ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- ;
- ;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
- DGPMVBUL ;ALB/MIR/MAC - SEND MOVEMENT BULLITENS; 12 Sep 1989
- +1 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- +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
